Hallo,

mit dieser Variante kann noch mehr Performance herausgeholt werden:

Sub CompressData()
    Dim wsh As Worksheet
    Dim rngDelete As Range
    Dim lngRow As Long, lngRowTimer As Long, lngTimerSecond As Long
    Dim lngRowAreaBegin As Long, lngRowLast As Long
    Dim sMsg As String
    Dim datDate As Date
    Dim lngTimer As Long
    Set wsh = Tabelle1
    Application.ScreenUpdating = False
    lngRow = 2
    lngRowTimer = 2
    lngRowLast = 2
    Do Until lngRow > wsh.UsedRange.SpecialCells(xlCellTypeLastCell).Row
        If IsDate(wsh.Cells(lngRow, 1).Value) Then
            If datDate = 0 Then
                datDate = wsh.Cells(lngRow, 1).Value
            Else
                If DateDiff("s", datDate, wsh.Cells(lngRow, 1)) < 60 Then
                    If lngRowAreaBegin = 0 Then
                        lngRowAreaBegin = lngRow
                    End If
                    lngRowLast = lngRow
                Else
                    SetRngDelete wsh, rngDelete, lngRowAreaBegin, lngRowLast
                    datDate = wsh.Cells(lngRow, 1).Value
                End If
            End If
        End If
        If Timer - lngTimerSecond >= 1 Then
            sMsg = " (" & lngRow - lngRowTimer & "/Sek.)"
            lngTimerSecond = Timer
            lngRowTimer = lngRow
        End If
        Application.StatusBar = "Analisiere Zeile " & lngRow & " ..." & sMsg
        If (Timer - lngTimer) > 10 Then
            lngTimer = Timer
            VBA.DoEvents
        End If
        lngRow = lngRow + 1
    Loop
    SetRngDelete wsh, rngDelete, lngRowAreaBegin, lngRowLast
    
    If Not rngDelete Is Nothing Then
        rngDelete.EntireRow.Delete shift:=xlUp
    End If
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub

Private Sub SetRngDelete(ByRef wsh As Worksheet, ByRef rngDelete As Range, ByRef lngRowAreaBegin As Long, ByRef lngRowLast As Long)
    If lngRowAreaBegin > 0 Then
        If rngDelete Is Nothing Then
            Set rngDelete = wsh.Range(wsh.Cells(lngRowLast, 1), wsh.Cells(lngRowAreaBegin, 1))
        Else
            Set rngDelete = Union(rngDelete, wsh.Range(wsh.Cells(lngRowLast, 1), wsh.Cells(lngRowAreaBegin, 1)))
        End If
        lngRowAreaBegin = 0
    End If
End Sub

Hierbei wird der Befehl Union für einen ganzen zusammenhängenden Block aufgerufen. Daher bleibt die Rate fast konstant bei 270 Zeilen pro Sekunde.

Die Befehle zum setzen der Range rngDelete wurde in die Sub SetRngDelete ausgelagert, da ansonsten die identischen Befehle in der do-loop-Schleife und am Ende vorhanden wäre.

LG, Ben