Sub HalbeStunde()
Dim fAuslesen() As Variant
Dim fÜbergabe() As Variant
Dim i As Long
Dim j As Long
Dim strTag As String
Dim dSpalte As Double
Sheets("Tabelle3").Select
Cells.Select
Selection.ClearContents
With Sheets("Tabelle2")
fAuslesen = Range(.Range("A2"), .Range("A2").End(xlDown)).Resize(, 3)
End With
ReDim fÜbergabe(1 To UBound(fAuslesen), 1 To 3)
For i = 1 To UBound(fAuslesen)
If Hour(fAuslesen(i, 1)) >= <strong>0</strong> And Hour(fAuslesen(i, 1)) <= <strong>24 </strong>Then
If strTag = "" Then strTag = Left(fAuslesen(i, 1), 4)
If strTag <> Left(fAuslesen(i, 1), 4) Then
strTag = Left(fAuslesen(i, 1), 4)
If Cells(1, Columns.Count).End(xlToLeft).Column + 1 = 2 Then
dSpalte = 1
Else
dSpalte = Cells(1, Columns.Count).End(xlToLeft).Column + 1
End If
Sheets("Tabelle3").Cells(1, dSpalte).Resize(j, 3) = fÜbergabe
j = 0
Erase fÜbergabe
ReDim fÜbergabe(1 To UBound(fAuslesen), 1 To 3)
End If
j = j + 1
fÜbergabe(j, 1) = fAuslesen(i, 1)
fÜbergabe(j, 2) = fAuslesen(i, 2)
fÜbergabe(j, 3) = fAuslesen(i, 3)
End If
Next i
Sheets("Tabelle3").Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1).Resize(j, 3) = fÜbergabe
Cells.Select
Cells.EntireColumn.AutoFit
End Sub