Werte in Zelle nach Leerzeichen per VBA Trennen

[Mario]

Hallo zusammen,

ich habe in einer vorgegebenen Datei bei der die Anfangs-und Endzeiten in einer Spalte stehen. Diese Zeiten möchte ich nun per Makro Trennen (nach dem ersten Leerzeichen), so das die Anfangs und die Endzeit in verschiedenen Spalten im Urzeitformat stehen.
Das funktioniert auch schon. Nun würde ich die getrennten Zeiten aber gerne auf den Tabellenblatt "Tabelle2" unter dem entsprechendem Datum ausgegeben haben. Des Weiteren sollen Zellen die Buchstaben enthalten nicht mit übertragen werden. Könnt ihr mir hier eventuell helfen?

Ich habe eine Musterdatei angehängt, da es so etwas verständlicher ist.

Vielen Dank und Gruß Mario

[atilla]

Hallo Mario,

teste mal. Ist nicht der schnellste Code, aber ich Denke da werden sowieso noch weitere Fragen kommen.
Dann kann man ja schauen, ob man etwas schnelleres programmiert.

Code:

Private Sub CommandButton1_Click()
   Dim i As Long, j As Long, k As Long
   Dim lngLastR As Long
   Dim lngLastC As Long
  
   With Sheets("Tabelle2")
      lngLastR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
      lngLastC = .Cells(3, .Columns.Count).End(xlToLeft).Column
      .Range(.Cells(4, 1), .Cells(lngLastR, lngLastC)).ClearContents
   End With
  
   lngLastR = Cells(Rows.Count, 1).End(xlUp).Row
   lngLastC = Cells(10, Columns.Count).End(xlToLeft).Column
  
   With Sheets("Tabelle2")
      For i = 12 To lngLastR
         For j = 5 To lngLastC
            If Weekday(Cells(10, j), vbMonday) < 6 Then
               If InStr(1, Cells(i, j).Value, " ") Then
                 .Cells(i - 8, j - 4 + k).Value = Split(Cells(i, j).Value)(0)
                 .Cells(i - 8, j - 4 + k + 1).Value = Split(Cells(i, j).Value)(1)
               End If
            End If
            k = k + 1
         Next j
         k = 0
      Next i
   End With
End Sub

[atilla]

Hallo Mario,

die vorige Lösung war doch sehr langsam, deshalb hier doch noch eine Ratz Fatz Lösung:

Code:

Private Sub CommandButton1_Click()
   Dim i As Long, j As Long, k As Long, n As Long
   Dim lngLastR As Long
   Dim lngLastC As Long
   Dim varFeld
   Dim arr()
  
   With Sheets("Tabelle2")
      lngLastR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
      lngLastC = .Cells(3, .Columns.Count).End(xlToLeft).Column
      .Range(.Cells(4, 1), .Cells(lngLastR, lngLastC)).ClearContents
   End With
  
   lngLastR = Cells(Rows.Count, 1).End(xlUp).Row
   lngLastC = Cells(10, Columns.Count).End(xlToLeft).Column
   varFeld = Range(Cells(10, 5), Cells(lngLastR, lngLastC))
   ReDim arr(lngLastR - 12, (lngLastC - 4) * 2)
   With Sheets("Tabelle2")
      For i = 1 To lngLastR - 11
         For j = 1 To lngLastC - 5
            If Weekday(varFeld(1, j), vbMonday) < 6 Then
               If InStr(1, varFeld(i + 2, j), " ") Then
                  arr(n, k) = Split(varFeld(i + 2, j))(0)
                  arr(n, k + 1) = Split(varFeld(i + 2, j))(1)
               End If
            End If
            k = k + 2
         Next j
         k = 0
         n = n + 1
      Next i
      .Range("A4").Offset(0, 0).Resize(n, (lngLastC - 4) * 2) = arr
   End With
End Sub

[Mario]

Hallo Atilla,

das funktioniert super :28:.
Ich danke dir. Spitze wie immer!

VG Mario