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