Hallo,

ich hab da ein Problem zu einem bestehenden Code.Bisher funktioniert das Makro wunderbar, nur soll jetzt in Zeile: 

    If Hour(fAuslesen(i, 1)) >= 0 And Hour(fAuslesen(i, 1)) <= 24 Then

die Uhrzeit geändert werden. nicht von 0 bis 24 Uhr, sondern von 00:00 bis 00:30. Leider bekomme ich dann alle Werte mit 0, also von 00:00 bis 00:59 Uhr. Wenn ich die Uhrzeit so schreibe 00:00:00 bringt er mir einen Fehler. Die Ausgangszelle sieht übringens so aus:  04.06.2012 00:03:13. Und dann kommen im 8 Minutenschritt weitere hinzu.

Hat hier jemand eine Idee??

Gruß Robert

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)) >= 0 And Hour(fAuslesen(i, 1)) <= 24 Then
        ' Datum merken - strTag ist beim Start leer
        If strTag = "" Then strTag = Left(fAuslesen(i, 1), 4)
        ' Datum vergleichen - mit dem was aktuell als Wert eingetragen werden soll
        If strTag <> Left(fAuslesen(i, 1), 4) Then
            ' wenn es ein anderes Datum ist das neue merken
            strTag = Left(fAuslesen(i, 1), 4)
            ' damit er auch in Spalte 1 anfängt
            If Cells(1, Columns.Count).End(xlToLeft).Column + 1 = 2 Then
                dSpalte = 1
            Else
                ' danach immer die nächste freie Spalte nehmen
                dSpalte = Cells(1, Columns.Count).End(xlToLeft).Column + 1
            End If
            'Im array stehen nur Daten vom selben Tag und das fügen ein
            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