Sub CompressData()
Dim wsh As Worksheet
Dim rngDelete As Range
Dim lngRow As Long
Dim datDate As Date
Dim lngTimer As Long
Set wsh = Tabelle1
Application.ScreenUpdating = False
lngRow = 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 rngDelete Is Nothing Then
Set rngDelete = wsh.Cells(lngRow, 1).EntireRow
Else
Set rngDelete = Union(rngDelete, wsh.Cells(lngRow, 1).EntireRow)
End If
Else
datDate = wsh.Cells(lngRow, 1).Value
End If
End If
End If
Application.StatusBar = "Analisiere Zeile " & lngRow & " ..."
If (Timer - lngTimer) > 10 Then
lngTimer = Timer
VBA.DoEvents
End If
lngRow = lngRow + 1
Loop
If Not rngDelete Is Nothing Then
rngDelete.Delete shift:=xlUp
End If
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub