Hallo,
freut mich, dass das Makro so funktioniert, wie du willst.
Mit dem folgenden Code werden die Fehltage als Kommentar in den betreffenden Zellen eingefügt:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngMonat As Long
Dim lngLSpalte As Long
Dim lngLZeile As Long
Dim arrMitarbeiter()
Dim lngZeile As Long
Dim lngSpalte As Long
Dim lngAnzahl As Long
Dim lngZaehler As Long
'Falls keine Eingabe in C2 erfolgt dann Makro verlassen
If Target.Address <> "$C$2" Then Exit Sub
'Meldungen ausschalten
Application.EnableEvents = False
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Inhalte Blatt Personalliste löschen
With Worksheets("Personalliste").Range("A7", Cells(Application.Max(7, Cells(Rows.Count, 1).End(xlUp).Row), 1)).Resize(, 8)
.ClearContents 'Inhalte löschen
.ClearComments 'Kommentar löschen
End With
With Worksheets("Ressourcenplan")
'letzte Spalte in Zeile 3 des Arbeitsblatts Ressourcenplan ermitteln ermitteln
lngLSpalte = .Cells(3, Columns.Count).End(xlToLeft).Column
'Letzte Zeile in Spalte C ermitteln
lngLZeile = .Cells(Rows.Count, 3).End(xlUp).Row
'Monat zur Auswertung bestimmen
Select Case Range("C2").Value
Case Is = "Jänner"
lngMonat = 1
Case Is = "Februar"
lngMonat = 2
Case Is = "März"
lngMonat = 3
Case Is = "April"
lngMonat = 4
Case Is = "Mai"
lngMonat = 5
Case Is = "Juni"
lngMonat = 5
Case Is = "Juli"
lngMonat = 6
Case Is = "August"
lngMonat = 8
Case Is = "September"
lngMonat = 9
Case Is = "Oktober"
lngMonat = 10
Case Is = "November"
lngMonat = 11
Case Is = "Dezember"
lngMonat = 12
End Select
'nun nach aktiven Mitarbeitern filtern
With .Range(.Cells(20, 1), .Cells(lngLZeile, lngLSpalte))
.AutoFilter Field:=4, Criteria1:="=aktiv"
End With
'Anzahl der gefilterten Datensätze ermitteln
For lngZeile = 21 To lngLZeile
If .Cells(lngZeile, 4).Value = "aktiv" Then lngAnzahl = lngAnzahl + 1
Next lngZeile
'Feld für Auswertung Redimensionieren
ReDim arrMitarbeiter(lngAnzahl, 8)
'nun gefilterte Zeilen durchlaufen und Daten in Feld einlesen
For lngZeile = 21 To lngLZeile
If .Rows(lngZeile).Hidden = False Then
lngZaehler = lngZaehler + 1
arrMitarbeiter(lngZaehler, 0) = .Cells(lngZeile, 2) 'Nummer des Mitarbeiters
arrMitarbeiter(lngZaehler, 1) = .Cells(lngZeile, 3) 'Name des Mitarbeiters
'Stunden des jeweiligen Monats suchen
For lngSpalte = 5 To lngLSpalte
If .Cells(20, lngSpalte) = Worksheets("Personalliste").Range("C2").Value Then
arrMitarbeiter(lngZaehler, 2) = .Cells(lngZeile, lngSpalte) 'Arbeitsstunden im Monat
Exit For
End If
Next lngSpalte
'nun Feiertage, Urlaub und Krank des Monats zählen
'dazu wieder alles Spalten durchlaufen
'zuerst wird geprüft, ob in Zeile 3 ein Datum stehn
For lngSpalte = 5 To lngLSpalte
If IsDate(.Cells(3, lngSpalte)) = True Then
'nun prüfen, ob Datum in dem gesuchten Monat liegt
If Month(.Cells(3, lngSpalte)) = lngMonat Then
'falls ja, dann prüfen, ob etwas in der betreffenden Spalte steht und entsprechenden Zähler erhöhen
If .Cells(lngZeile, lngSpalte).Value = "FT" Then
arrMitarbeiter(lngZaehler, 3) = arrMitarbeiter(lngZaehler, 3) + 1 'Feiertag
arrMitarbeiter(lngZaehler, 6) = arrMitarbeiter(lngZaehler, 6) & Chr(10) & .Cells(3, lngSpalte) 'Datum des Feiertages
End If
If .Cells(lngZeile, lngSpalte).Value = "UR" Then
arrMitarbeiter(lngZaehler, 4) = arrMitarbeiter(lngZaehler, 4) + 1 'Urlaub
arrMitarbeiter(lngZaehler, 7) = arrMitarbeiter(lngZaehler, 7) & Chr(10) & .Cells(3, lngSpalte)
End If
If .Cells(lngZeile, lngSpalte).Value = "KH" Then
arrMitarbeiter(lngZaehler, 5) = arrMitarbeiter(lngZaehler, 5) + 1 'Krank
arrMitarbeiter(lngZaehler, 8) = arrMitarbeiter(lngZaehler, 8) & Chr(10) & .Cells(3, lngSpalte)
End If
End If
End If
Next lngSpalte
End If
Next lngZeile
'Filter wieder aufheben
'nun nach aktiven Mitarbeitern filtern
With .Range(.Cells(20, 1), .Cells(lngLZeile, lngLSpalte))
.AutoFilter
End With
End With
'Nun Daten in Personalliste übertragen
With Worksheets("Personalliste")
For lngZeile = 1 To lngZaehler
For lngSpalte = 0 To 5
With .Cells(lngZeile + 6, lngSpalte + 1)
.Value = arrMitarbeiter(lngZeile, lngSpalte)
'Daten der Fehlzeiten als Kommentar einfügen
If lngSpalte > 2 And arrMitarbeiter(lngZeile, lngSpalte + 3) <> "" Then
.AddComment
.Comment.Visible = False
.Comment.Text Text:=Right(arrMitarbeiter(lngZeile, lngSpalte + 3), Len(arrMitarbeiter(lngZeile, lngSpalte + 3)) - 1) 'Daten als Kommentar ausgeben
With .Comment.Shape.TextFrame
.AutoSize = True
End With
End If
End With
Next lngSpalte
Next lngZeile
End With
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
'Meldungen wieder anzeigen
Application.EnableEvents = True
End Sub
Revanchieren brauchst du dich bei mir nicht, ich mache das wie alle hier im Forum aus Spaß an der Freude
.
Gruß
M.O.
