06.07.2021, 19:11
Ich habe im internet ein vba code gefunden was eigentlich schon gut funktioniert, mir fehlen noch paar Erweiterungen
der script ermittelt anfangs und enddatum von ein U drin steht soweit so gut.
zb.
01.01 02.01. 03.01. 04.01 05.01 06.01 07.01 08.01 09.01 10.01 11.01 12.01 13.01 14.01 15.01 16.01
MO DI MI DO FR SA SO MO Di Mi DO FR SA SO MO DI
Mustermann U U U U X X U U U U X X
Aktuell sieht die Ausgabe so aus
Musterman 02.01. 05.01 08.01 11.01
ich möchte das es die Wochenenden mit berücksichtigt das wenn der Folgende Montag ein U hat soll es die X wie U behandeln
Musterman 02.01 11.01
zusätzlich alle abgelaufen datum sollen gelöscht werden ist es möglich den code so Umzuschreiben ???
Mfg
der script ermittelt anfangs und enddatum von ein U drin steht soweit so gut.
zb.
01.01 02.01. 03.01. 04.01 05.01 06.01 07.01 08.01 09.01 10.01 11.01 12.01 13.01 14.01 15.01 16.01
MO DI MI DO FR SA SO MO Di Mi DO FR SA SO MO DI
Mustermann U U U U X X U U U U X X
Aktuell sieht die Ausgabe so aus
Musterman 02.01. 05.01 08.01 11.01
ich möchte das es die Wochenenden mit berücksichtigt das wenn der Folgende Montag ein U hat soll es die X wie U behandeln
Musterman 02.01 11.01
zusätzlich alle abgelaufen datum sollen gelöscht werden ist es möglich den code so Umzuschreiben ???
Code:
Sub Urlaubszusammenfassung()
Quelle = "Tabelle1" 'Name der Quelltabelle
AbZeileQ = 1 'Zeile, in welcher die Datumswerte stehen
AbSpalteQ = 1 'Spalte, in welcher die Mitarbeiternamen stehen
Ziel = "Tabelle2" 'Name der Zieltabelle
AbZeileZ = 1 'Zeile, ab welcher die Ergebnisdaten eingetragen werden sollen
AbSpalteZ = 1 'Spalte, ab welcher die Ergebnisdaten eingetragen werden sollen
Kennz = "U" 'Kennzeichen, nach welchem gesucht werden soll
ZeileQ = AbZeileQ + 1 'Beginne in Quelltabelle in der Zeile mit erstem Mitarbeiter
ZeileZ = AbZeileZ 'Beginne in der Zieltabelle in der ersten Ergebniszeile
MA = Worksheets(Quelle).Cells(ZeileQ, AbSpalteQ).Value 'Mitarbeiternamen lesen
Do While MA <> "" 'Solange ein Mitarbeitername gefunden wird, Schleife durchführen
SpalteQ = AbSpalteQ + 1 'Beginne in der Quelltabelle in der Spalte mit dem ersten Datumswert
SpalteZ = AbSpalteZ + 1 'Beginne in der Zieltabelle in der Spalte nach dem Mitarbeiternamen
Beginn = "" 'Beginndatum des Urlaubszeitraumes löschen
Worksheets(Ziel).Cells(ZeileZ, AbSpalteZ).Value = MA 'Mitarbeiternamen in vorgegebene Spalte der Zieltabelle übertragen
Dat = Worksheets(Quelle).Cells(AbZeileQ, SpalteQ).Value ' Datumswert aulsesen
Do While Dat <> "" 'Solange es noch Datumswerte gibt, Schleife wiederholen
If Worksheets(Quelle).Cells(ZeileQ, SpalteQ).Value = Kennz Then ' Wenn das Kennzeichen in der Zeile des MA gefunden wird ...
If Beginn = "" Then '... und nicht bereits ein Urlaubsbeginn voerher erkannt wurde ...
Worksheets(Ziel).Cells(ZeileZ, SpalteZ).Value = Dat ' ... Urlaubsbeginn in Zieltabelle eintragen und ...
Beginn = Dat ' ... Beginndatum zwischenspeichern
SpalteZ = SpalteZ + 1 'nächster Eintrag in Zieltabelle erfolgt in nächster Spalte
End If
Else ' kein Urlaubstag
If Beginn <> "" Then ' Wenn laufender Urlaub ...
Ende = Worksheets(Quelle).Cells(AbZeileQ, SpalteQ - 1).Value ' ... als Enddatum den gestrigen Tag festlegen
If Beginn <> Ende Then ' Wenn Beginn und Ende unterschiedlich (mehrtätiger Urlaub) ...
Worksheets(Ziel).Cells(ZeileZ, SpalteZ).Value = Ende ' ... Enddatum eintragen
'SpalteZ = SpalteZ + 1 'nächster Eintrag in Zieltabelle erfolgt in nächster Spalte
End If
Beginn = "" 'Beginndatum des Urlaubszeitraumes löschen
SpalteZ = SpalteZ + 2 'nächster Eintrag in Zieltabelle erfolgt in übernächster Spalte - dadurch leere Zelle(n) nach Urlaub
End If
End If
SpalteQ = SpalteQ + 1 'nächsten Tag des Jahres betrachten ...
Dat = Worksheets(Quelle).Cells(AbZeileQ, SpalteQ).Value '... und dessen Datumswert zwischenspeichern
Loop 'alle Datumswerte (des Jahres) durch
ZeileQ = ZeileQ + 1 'nächste Zeile für Mitarbeiter in Quelltabelle
ZeileZ = ZeileZ + 1 'nächste Zeile für Mitarbeiter in Quelltabelle
MA = Worksheets(Quelle).Cells(ZeileQ, AbSpalteQ).Value'Mitarbeiternamen lesen
Loop 'alle Mitarbeiter durch
MsgBox "Fertig."
End Sub
Mfg