Hallo Zusammen,
In Spalte 1 ab Zeile 19 stehen Namen z.B. Max Mustermann. Dieser Name kann auch öfters vorkommen. Ab Spalte 7 Zeile 18 sind die Daten für einen variablen Monat eingetragen. Ab Spalte 7 Zeile 19 können in unterschiedlichen Zeilen und Spalten (also für eine Person und an verschiedenen Daten eine Uhrzeit wie "07:00" eingetragen sein. Wenn für die gleiche Person an gleichen Tagen eine Uhrzeit eingetragen ist, sollen die beiden Zellen gelb markiert werden.
Mein Ansatz:
Sub MarkiereDoppelteUhrzeiten()
Dim ws As Worksheet
Dim startRow As Long, startCol As Long
Dim endRow As Long, endCol As Long
Dim i As Long, j As Long
Dim person As String
Dim dict As Object
Dim ZellInhalt As Variant
Dim key As String
Dim dictValue As Variant
' Setze das Arbeitsblatt
Set ws = ThisWorkbook.Sheets("Main") ' Passe den Blattnamen an
' Anfangszeile und -spalte
startRow = 19
startCol = 7
' Ende der Zeilen und Spalten (dynamisch ermittelt)
endRow = ws.Cells(ws.Rows.count, 1).End(xlUp).Row
endCol = ws.Cells(18, ws.Columns.count).End(xlToLeft).Column
' Initialisiere das Dictionary
Set dict = CreateObject("Scripting.Dictionary")
' Durchlaufe die Namen und Daten
For i = startRow To endRow
person = ws.Cells(i, 1).value
For j = startCol To endCol
ZellInhalt = ws.Cells(i, j).value
' Überprüfe, ob der Zellinhalt eine Uhrzeit ist und nicht leer ist
If IsTime(ZellInhalt) Then
' Schlüssel für das Dictionary erstellen
key = person & "_" & ws.Cells(18, j).value & "_" & Format(ZellInhalt, "hh:mm")
' Überprüfe, ob der Schlüssel bereits existiert
If dict.exists(key) Then
' Hole die gespeicherte Position
dictValue = dict(key)
' Stelle sicher, dass die gespeicherte Position auch eine Uhrzeit enthält
If IsTime(ws.Cells(dictValue(0), dictValue(1)).value) Then
' Markiere beide Zellen gelb
ws.Cells(i, j).Interior.Color = RGB(255, 255, 0) ' Gelb
ws.Cells(dictValue(0), dictValue(1)).Interior.Color = RGB(255, 255, 0) ' Gelb
End If
Else
' Füge den Schlüssel und die Zellposition zum Dictionary hinzu
dict.Add key, Array(i, j)
End If
End If
Next j
Next i
End Sub
Function IsTime(value As Variant) As Boolean
' Prüfe, ob der Wert eine gültige Uhrzeit im Excel-Format ist
Dim tempTime As Date
On Error Resume Next
tempTime = TimeValue(value)
IsTime = (Err.Number = 0)
On Error GoTo 0
End Function
Leider klappt der Code nicht, da, wenn eine Uhrzeit eingetragen ist "07:00" nicht erkannt also IsTime =false ist. Kann mir jemand helfen, was ich hier verändern muss, bitte?
Vielen Dank
|