Option Explicit
Private Const cTEST = True ->Schalter Test
->true: zu löschende Zeilen werden nur rot markiert
->false: zu löschende Zeilen werden gelöscht
Private Const cZEILEAUTOFILTER = 1
Private Const cABZEILE = 2 ->Zeile ab der Gruppen gesucht werden sollen
Private Const cSPA = 1 ->Spalte Datum
Private Const cSPB = 2 ->Spalte Uhrzeit
Private Const cSPC = 3 ->Suchspalte C
Private Const cSPJ = 10 'Spalte Zeitdifferenz in Minuten zwischen Anf-und Ende-Zeile
Private Const cCIROT = 3 ->Farbindex rot
Private Const cCIGRUEN = 50->Farbindex gruen (Meeresgrün)
Private Const cCIGELB = 6 'Farbindex gelb
'*********************************************************************************
Sub Excel_AutofilterLoeschen()
Dim ws As Worksheet
Set ws = ActiveSheet
->Prüfen, ob Autofilter schon gesetzt ist
If ws.AutoFilterMode Then ws.Cells(cZEILEAUTOFILTER, cSPJ).AutoFilter
AUFRAEUMEN:
Set ws = Nothing
End Sub
'*********************************************************************************
Sub Excel_AutofilterSetzenSpaltJ()
Dim ws As Worksheet
Dim lZahl As Long, sZahl As String, sTmp As String, bNok As Boolean
->Untere Grenzzahl abfragen
bNok = True
Do While bNok
sZahl = InputBox( _
Bitte geben Sie die untere Grenze für den Autofilter & _
->Zeitdifferenz' als Ganzzahl ein., _
Eingabe untere Grenze Zeitdifferenz, _
1)
If sZahl = Then Exit Sub
On Error Resume Next: lZahl = sZahl: Err.Clear: On Error GoTo 0
sTmp = lZahl
If sTmp = sZahl Then bNok = False Else MsgBox Wert unzulässig: & sZahl
Loop
Set ws = ActiveSheet
->Prüfen, ob Autofilter schon gesetzt ist, dann löschen
If ws.AutoFilterMode Then ws.Cells(cZEILEAUTOFILTER, cSPJ).AutoFilter
->Autofilter setzen
On Error Resume Next->falls Liste leer ist
ws.Cells(cZEILEAUTOFILTER, cSPJ).AutoFilter _
Field:=cSPJ, _
Criteria1:=> & lZahl
On Error GoTo 0
AUFRAEUMEN:
Set ws = Nothing
End Sub
'*********************************************************************************
Sub Excel_SpalteCGruppenAnfEndeZeileStehenLassen()
'*** Sucht Gruppen gleicher Begriffe in Spalte C
'***
'*** Von den Zeilen der Gruppe werden alle Zeilen
'*** außer der 1. und letzten Zeile gelöscht
'***
'*** Hat die Gruppe nur eine Zeile bleibt die Zeile unverändert
'*** Hat die Gruppe mehr als 1 Zeile, wird
'*** - in der ersten Zeile die Schrift grun
'*** - in der letzten Zeile die Schrift rot
'*** gesetzt. Dann wird auch die Zeitdifferenz in Spalte J gesetzt.
'*** (Spalte A: Datum, Spalte B: Uhrzeit
Dim ws As Worksheet
Dim lLetzteZeile As Long, lLetzteSpalte As Long
Dim ze As Long, za As Long, x As Long
Dim lMinuten As Long
Set ws = ActiveSheet
With ws
lLetzteSpalte = .UsedRange.Column + .UsedRange.Columns.Count - 1
lLetzteZeile = .UsedRange.Row + .UsedRange.Rows.Count - 1
ze = lLetzteZeile
Do While ze > cABZEILE
->*** nächste Ende-Zeile einer Gruppe suchen
Do While ze > cABZEILE
->Zelle nicht leer ?
If .Cells(ze, cSPC).Value <> Then Exit Do->Ende-Zeile gefunden
->nächste Zeile
ze = ze - 1
Loop
->*** keine Ende-Zeile mehr vorhanden ? ->
If Not (ze > cABZEILE) Then Exit Do
->*** Anfangs-Zeile dieser Gruppe bestimmen
za = ze
Do While (za > cABZEILE)
za = za - 1
->anderer Begriff ?
If .Cells(za, cSPC).Value <> .Cells(ze, cSPC).Value Then
za = za + 1
Exit Do
End If
Loop
->ggf. Schrift-Farbe setzen, wenn Gruppe mehr als eine Zeile hat
->und Zeitdifferenz in Spalte J
If za <> ze Then
.Range(.Cells(za, 1), .Cells(za, lLetzteSpalte)).Font.ColorIndex = cCIGRUEN
.Range(.Cells(ze, 1), .Cells(ze, lLetzteSpalte)).Font.ColorIndex = cCIROT
lMinuten = ZeitdifferenzInMinuten(ws, za, ze, cSPA, cSPB)
If lMinuten < 9999 Then
.Cells(za, cSPJ).Value = lMinuten
.Cells(ze, cSPJ).Value = lMinuten
Else
.Cells(za, cSPJ).Value = FEHLER
.Cells(ze, cSPJ).Value = FEHLER
End If
End If
->*** ggf. Zwischen-Zeilen in dieser Gruppe löschen
For x = (ze - 1) To (za + 1) Step -1
->Testbetrieb ?
If cTEST Then
->Zellen der zu löschenden Zeile rot markieren
.Range(.Cells(x, 1), .Cells(x, lLetzteSpalte)).Interior.ColorIndex = cCIGELB
Else
->Zeile löschen
.Rows(x).Delete
End If
Next
->*** nächsten Suchanfang setzen
ze = za - 1
Loop
End With
AUFRAEUMEN:
Set ws = Nothing
End Sub
'**********************************************************************************
Private Function ZeitdifferenzInMinuten(ws As Worksheet, _
za As Long, ze As Long, _
SPDatum As Long, SPUhrzeit As Long) As Long
->*** Berechnung der Zeitdifferenz in Minuten
->*** bei Fehler wird eine zeitdifferenz > 9999 zurückgeliefert
Dim dDateDatum_za As Date, dDateUhrzeit_za As Date
Dim dDateDatum_ze As Date, dDateUhrzeit_ze As Date
Dim lStunde As Long, lMinute As Long
Dim dZeitdifferenz As Date
On Error Resume Next
ZeitdifferenzInMinuten = 100000
->*** Anfangszeit
If ws.Cells(za, SPDatum).Value = Then Exit Function
dDateDatum_za = ws.Cells(za, SPDatum).Value
If Err.Number <> 0 Then Err.Clear: Exit Function
If ws.Cells(za, SPUhrzeit).Value = Then Exit Function
dDateUhrzeit_za = ws.Cells(za, SPUhrzeit).Value
If Err.Number <> 0 Then Err.Clear: Exit Function
lStunde = Hour(dDateUhrzeit_za)
lMinute = Minute(dDateUhrzeit_za)
dDateDatum_za = DateAdd(h, lStunde, dDateDatum_za)
dDateDatum_za = DateAdd(n, lMinute, dDateDatum_za)
->*** Endezeit
If ws.Cells(ze, SPDatum).Value = Then Exit Function
dDateDatum_ze = ws.Cells(ze, SPDatum).Value
If Err.Number <> 0 Then Err.Clear: Exit Function
If ws.Cells(ze, SPUhrzeit).Value = Then Exit Function
dDateUhrzeit_ze = ws.Cells(ze, SPUhrzeit).Value
If Err.Number <> 0 Then Err.Clear: Exit Function
lStunde = Hour(dDateUhrzeit_ze)
lMinute = Minute(dDateUhrzeit_ze)
dDateDatum_ze = DateAdd(h, lStunde, dDateDatum_ze)
dDateDatum_ze = DateAdd(n, lMinute, dDateDatum_ze)
->*** Zeitdifferenz
If dDateDatum_ze < dDateDatum_za Then Exit Function
ZeitdifferenzInMinuten = DateDiff(n, dDateDatum_za, dDateDatum_ze)
End Function
