Hier mal der ganze Code.....der Vollständigkeits halber....
Option Explicit
Dim rngZelle As Range
Dim lngZielZeile As Long
Dim lngLetzteZeileQuelle As Long
Dim lngSpalte As Long
Dim lngLetzteZeileZiel As Long
Dim lngZeile As Long
Dim strName As String
Dim strQuelle As String
Dim strZiel As String
Dim wksBlatt As Worksheet
Dim strSchicht As String
Dim strArbeitszeit As String
Dim strUhrzeit As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngZielSpalte As Long
Dim lngZielZeile As Long
strQuelle = "Dienstplan Gruppe A"
strZiel = "Tagdienstplan"
'Wenn das Datum in D2 in "Tagdienstplan" geändert wurde:
If Target.Address = "$A$2" Then
'alte Werte löschen:
lngLetzteZeileZiel = Worksheets(strZiel).UsedRange.Rows.Count
Application.EnableEvents = False
On Error GoTo Fehler
Worksheets(strZiel).Range("B5:B34").ClearContents
Worksheets(strZiel).Range("D5:D34").ClearContents
'Alle Blätter durchgehen, deren Name mit "Dienstplan" anfängt:
For Each wksBlatt In ThisWorkbook.Worksheets
If Left(wksBlatt.Name, 10) = "Dienstplan" Then
'In dieser Zeile beginnt die Eintragung der Namen:
lngLetzteZeileZiel = 3
'ermitteln, wie viele Zeilen die aktuelle Dienstplan-Tabelle hat:
lngLetzteZeileQuelle = wksBlatt.Cells(Rows.Count, 6).End(xlUp).Row
'Die Spalte des Suchbegriffs ermitteln:
lngSpalte = Application.WorksheetFunction.Match(Target, wksBlatt.Range("A6:Av6"), 0)
'Die Zellen mit "X" in der Spalte ermitteln:
Call Anwesenheit("X")
'Die Zellen mit "FT" in der Spalte ermitteln:
Call Anwesenheit("FT")
'Die Zellen mit "U" in der Spalte ermitteln:
Call Anwesenheit("U")
'Die Zellen mit "K" in der Spalte ermitteln:
Call Anwesenheit("K")
'Die Zellen mit "F" in der Spalte ermitteln:
Call Anwesenheit("H")
'Die Zellen mit "F" in der Spalte ermitteln:
Call Anwesenheit("F")
'Die Zellen mit "X4" in der Spalte ermitteln:
Call Anwesenheit("X4")
'Die Zellen mit "X6" in der Spalte ermitteln:
Call Anwesenheit("X6")
'Die Zellen mit "X8" in der Spalte ermitteln:
Call Anwesenheit("X8")
End If
Next wksBlatt
'Zeilen ohne Besetzung ausblenden
With Worksheets(strZiel)
For lngZeile = 3 To 17
If Application.WorksheetFunction.CountA(.Range("B" & lngZeile & ":G" & lngZeile)) = 0 _
Then
.Rows(lngZeile).Hidden = True
Else
.Rows(lngZeile).Hidden = False
End If
Next lngZeile
End With
End If
Fehler:
'Events wieder einschalten (auch wenn ein Fehler auftritt):
Application.EnableEvents = True
End Sub
Sub Anwesenheit(strMerkmal As String)
Dim lngZielSpalte As Long
Dim lngZielZeile As Long
With wksBlatt
Select Case wksBlatt.Name
Case "Dienstplan Gruppe A"
lngZielSpalte = 2
Case "Dienstplan Gruppe B"
lngZielSpalte = 4
End Select
For Each rngZelle In .Range(.Cells(7, lngSpalte), .Cells(lngLetzteZeileQuelle, lngSpalte))
If rngZelle = strMerkmal Then
'Je nach Schicht den Namen auslesen:
Select Case .Cells(rngZelle.Row, 6)
Case "Früh"
If UCase(strMerkmal) = "X" Then
strSchicht = "Früh"
strName = .Cells(rngZelle.Row, 1)
strArbeitszeit = .Cells(rngZelle.Row + 1, 5)
Select Case strArbeitszeit
Case "T"
lngZielZeile = 5
Case "V", "VH"
lngZielZeile = 6
Case "TT"
lngZielZeile = 7
End Select
ElseIf UCase(strMerkmal) = "X4" Then
strSchicht = "Früh"
strName = .Cells(rngZelle.Row, 1)
strArbeitszeit = .Cells(rngZelle.Row + 1, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 5
End Select
ElseIf UCase(strMerkmal) = "X6" Then
strSchicht = "Früh"
strName = .Cells(rngZelle.Row, 1)
strArbeitszeit = .Cells(rngZelle.Row + 1, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 6
End Select
ElseIf UCase(strMerkmal) = "X8" Then
strSchicht = "Früh"
strName = .Cells(rngZelle.Row, 1)
strArbeitszeit = .Cells(rngZelle.Row + 1, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 7
End Select
Else
'Wenn FT, U oder K
strName = .Cells(rngZelle.Row, 1)
End If
Case "Morgen"
If UCase(strMerkmal) = "X" Then
strSchicht = "Morgen"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL"
lngZielZeile = 8
Case "V", "VH"
lngZielZeile = 10
Case "TT"
lngZielZeile = 9
End Select
ElseIf UCase(strMerkmal) = "X4" Then
strSchicht = "Morgen"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 8
End Select
ElseIf UCase(strMerkmal) = "X6" Then
strSchicht = "Morgen"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 9
End Select
ElseIf UCase(strMerkmal) = "X8" Then
strSchicht = "Morgen"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 10
End Select
Else
'Wenn FT, U oder K
strName = .Cells(rngZelle.Row - 1, 1)
End If
Case "Spät"
If UCase(strMerkmal) = "X" Then
strSchicht = "Spät"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "TL"
lngZielZeile = 11
Case "V", "VH"
lngZielZeile = 12
Case "TT"
lngZielZeile = 13
Case "T"
lngZielZeile = 14
End Select
ElseIf UCase(strMerkmal) = "X4" Then
strSchicht = "Spät"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 14
End Select
ElseIf UCase(strMerkmal) = "X6" Then
strSchicht = "Spät"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 13
End Select
ElseIf UCase(strMerkmal) = "X8" Then
strSchicht = "Spät"
strName = .Cells(rngZelle.Row - 1, 1)
strArbeitszeit = .Cells(rngZelle.Row, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 12
End Select
Else
'Wenn FT, U oder K
strName = .Cells(rngZelle.Row - 1, 1)
End If
Case "Nacht"
If UCase(strMerkmal) = "X" Then
strSchicht = "Nacht"
strName = .Cells(rngZelle.Row - 2, 1)
strArbeitszeit = .Cells(rngZelle.Row - 1, 5)
Select Case strArbeitszeit
Case "V", "VH"
lngZielZeile = 15
Case "T", "TL"
lngZielZeile = 16
Case "TT"
lngZielZeile = 17
End Select
ElseIf UCase(strMerkmal) = "X4" Then
strSchicht = "Nacht"
strName = .Cells(rngZelle.Row - 2, 1)
strArbeitszeit = .Cells(rngZelle.Row - 1, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 17
End Select
ElseIf UCase(strMerkmal) = "X6" Then
strSchicht = "Nacht"
strName = .Cells(rngZelle.Row - 2, 1)
strArbeitszeit = .Cells(rngZelle.Row - 1, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 16
End Select
ElseIf UCase(strMerkmal) = "X8" Then
strSchicht = "Nacht"
strName = .Cells(rngZelle.Row - 2, 1)
strArbeitszeit = .Cells(rngZelle.Row - 1, 5)
Select Case strArbeitszeit
Case "T", "TL", "V", "TT", "VH"
lngZielZeile = 15
End Select
Else
'Wenn FT, U, F oder K
strName = .Cells(rngZelle.Row - 2, 1)
End If
End Select
'Events ausschalten, damit das Makro beim Eintragen der Namen nicht wieder gestartet wird: _
Application.EnableEvents = False
On Error GoTo Fehler
'Namen in den Tagdienstplan eintragen:
Select Case UCase(strMerkmal)
Case "X"
Worksheets(strZiel).Cells(lngZielZeile, lngZielSpalte) = Worksheets(strZiel).Cells( _
lngZielZeile, lngZielSpalte) & vbLf & strName
Case "X4"
Worksheets(strZiel).Cells(lngZielZeile, lngZielSpalte) = Worksheets(strZiel).Cells( _
lngZielZeile, lngZielSpalte) & vbLf & strName
Case "X6"
Worksheets(strZiel).Cells(lngZielZeile, lngZielSpalte) = Worksheets(strZiel).Cells( _
lngZielZeile, lngZielSpalte) & vbLf & strName
Case "X8"
Worksheets(strZiel).Cells(lngZielZeile, lngZielSpalte) = Worksheets(strZiel).Cells( _
lngZielZeile, lngZielSpalte) & vbLf & strName
Case "FT", "F"
Worksheets(strZiel).Cells(20, lngZielSpalte) = Worksheets(strZiel).Cells(18, _
lngZielSpalte) & vbLf & strName
Case "U"
Worksheets(strZiel).Cells(21, lngZielSpalte) = Worksheets(strZiel).Cells(19, _
lngZielSpalte) & vbLf & strName
Case "K"
Worksheets(strZiel).Cells(22, lngZielSpalte) = Worksheets(strZiel).Cells(20, _
lngZielSpalte) & vbLf & strName
Case "H"
Worksheets(strZiel).Cells(23, lngZielSpalte) = Worksheets(strZiel).Cells(20, _
lngZielSpalte) & vbLf & strName
End Select
End If
Next rngZelle
End With
Fehler:
'Events wieder einschalten (auch wenn ein Fehler auftritt):
Application.EnableEvents = True
End Sub