AW: Zellen automatisch markieren
18.01.2009 14:44:00
Peter
Hallo Judith,
hier noch eine driite Variante:
Option Explicit
'
' In eine Tabelle werden Namen und Arbeitszeiten eingetragen.
' Daneben, in einem separaten Tabellenteil sollen sie Zellen markiert werden,
' die diesen Arbeitszeiten entsprechen.
' Die Anzahl der Mitarbeiter ist verschieden.
'
Public Sub ZeitenMarkieren()
Dim lZeile As Long ' die Zeile der Mitarbeiter
Dim iSpalte_Q As Integer ' die Spalten D - I
Dim iSpalte_Z As Integer ' die Spalten M - BP
Dim iSpalte_S As Integer ' die neue Start-Spalte für die Bis-Zeit
Dim rBereich As String ' der Bereich, der zu markieren sein wird
With ThisWorkbook.Worksheets("Schichtplan")
.Range("M2:BP250").Interior.ColorIndex = xlNone ' alle farbigen Markierungen löschen
For lZeile = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Zeile 2 bis Ende abarbeiten
For iSpalte_Q = 4 To 8 Step 2 ' die Spalten D - I paarweise abarbeiten
If Trim(.Cells(lZeile, iSpalte_Q).Value) "" And _
Trim(.Cells(lZeile, iSpalte_Q + 1).Value) "" Then ' Von-Bis gefüllt ?
If IsNumeric(.Cells(lZeile, iSpalte_Q).Value) Then ' Von nummerisch ?
For iSpalte_Z = 13 To 68 ' die Spalten M - BP abarbeiten
If Hour(.Cells(lZeile, iSpalte_Q).Value) = _
Hour(.Cells(1, iSpalte_Z).Value) And _
Minute(.Cells(lZeile, iSpalte_Q).Value) = _
Minute(.Cells(1, iSpalte_Z).Value) Then
If rBereich = "" Then ' die gefundene Zelladresse merken
rBereich = Spaltenbuchstabe(iSpalte_Z) & lZeile
Else
rBereich = rBereich & "," & Spaltenbuchstabe(iSpalte_Z) & lZeile
End If
iSpalte_S = iSpalte_Z + 1 ' die Folgespalte merken
Exit For ' For/Next hier verlassen
End If
Next iSpalte_Z
If IsNumeric(.Cells(lZeile, iSpalte_Q + 1).Value) Then ' Bis nummerisch ?
For iSpalte_Z = iSpalte_S To 68 ' nächste Spalte bis Ende durchsuchen
If Hour(.Cells(lZeile, iSpalte_Q + 1).Value) = _
Hour(.Cells(1, iSpalte_Z).Value) And _
Minute(.Cells(lZeile, iSpalte_Q + 1).Value) = _
Minute(.Cells(1, iSpalte_Z).Value) Then
rBereich = rBereich & ":" & Spaltenbuchstabe(iSpalte_Z) & lZeile
Exit For ' For/Next hier, nachdem gefunden wurde, verlassen
End If
Next iSpalte_Z
End If
End If
End If
Next iSpalte_Q
Next lZeile
End With
If rBereich "" Then ' wurden Übereinstimmungen gefunden ?
Range(rBereich).Interior.ColorIndex = 35 ' hellgrün markieren
End If
End Sub
'
' die nummerische Spalte in einen Spaltenbuchstaben umwandeln
'
Public Function Spaltenbuchstabe(SpaltenNummer As Integer) As String
Spaltenbuchstabe = Replace(Cells(1, SpaltenNummer).Address(0, 0), "1", "")
End Function
Gruß Peter