Zeilen in Spalten, aber kompliziert !!

Sub Fuergilgamesh()
  
  Dim ws As Worksheet, ws2 As Worksheet
  Dim z As Long, x As Long, l_first As Long, s_tmp As String
  Dim d_date As Date
  
  On Error GoTo Aufraeumen

  
  Set ws = ActiveSheet
  
 ->ersten Wert day suchen in Spalte 1
  l_first = 0
  For x = 1 To 100
    If Left(ws.Cells(x, 1).Value, 3) = day Then
      l_first = x: Exit For
    End If
  Next x
  If l_first = 0 Then
    MsgBox (Keinen Anfang auf dem Blatt gefunden.)
    GoTo Aufraeumen
  End If
  
 ->neues Blatt anlegen und Überschriften
  Set ws2 = Worksheets.Add(After:=ws)
  z = 1
  With ws2.Cells(z, 1): .Value = day: .Font.Bold = True: End With
  With ws2.Cells(z, 2): .Value = tim: .Font.Bold = True: End With
  With ws2.Cells(z, 3): .Value = eb: .Font.Bold = True: End With
  z = z + 1
 ->Zahlenformat für eb
  ws2.Columns(3).NumberFormat = 0.0
  
  x = l_first
  Do
    If Left(ws.Cells(x, 1).Value, 3) = day Then
      s_tmp = ws.Cells(x, 1).Value
      s_tmp = Right(s_tmp, Len(s_tmp) - 4)->day  abschneiden
      ws2.Cells(z, 1).Value = s_tmp
    Else
      ws.Activate: ws.Cells(x - 1, 1).Select
      MsgBox (Bis zur Zeile  & (x - 1) &  wurde transponiert.)
      Exit Do
    End If
    If Left(ws.Cells(x + 1, 1).Value, 3) = tim Then
      s_tmp = ws.Cells(x + 1, 1).Value
      s_tmp = Right(s_tmp, Len(s_tmp) - 4)->tim  abschneiden
      ws2.Cells(z, 2).Value = s_tmp
    Else
      ws.Activate: ws.Cells(x, 1).Select
      MsgBox (Bis zur Zeile  & x &  wurde transponiert.)
      Exit Do
    End If
    If Left(ws.Cells(x + 2, 1).Value, 2) = EB Then
      s_tmp = ws.Cells(x + 2, 1).Value
      s_tmp = Right(s_tmp, Len(s_tmp) - 3)->EB  abschneiden
      ws2.Cells(z, 3).Value = s_tmp
    Else
      ws.Activate: ws.Cells(x + 1, 1).Select
      MsgBox (Bis zur Zeile  & (x + 1) &  wurde transponiert.)
      Exit Do
    End If
    z = z + 1
    x = x + 3
  Loop
Aufraeumen:
  Set ws = Nothing: Set ws2 = Nothing
End Sub