Hallo zusammen, 

ich brauche Hilfe mit VBA bzw. einem Makro. Ich beherrsche VBA nicht habe mich aber in dieses Makro versucht reinzudenken. 

Kontext die Excel beherbergt drei Arbeitsblätter

-Stammdaten

- Dienstplan

- Auswertung

Das Makro soll die Daten (Tag, Mitarbeiter, Arbietszeit in Std.) aus dem Arbeitsblatt "Dienstplan" auslesen und im Arbeitsblatt "Auswertung" in eine fortlaufende Liste übertragen. Ich habe das Makro zur Verfügung gestellt bekommen, erhalte aber leider immer wieder den selben Fehler. Das Datum der jeweiligen Schicht, wird falsch ausgelesen, und immer mit einem Tag versatz aufgelistet (z.B. anstatt des 01.01 wird der 02.01. usw. ausgeworfen).

Ich habe bereits mit Hilfe von ChatGPT versucht den Code zu korrigieren und auch neu zu erstellen bin aber leider gescheitert. Ich hoffe das mir ein VBA-Profi helfen kann.

Hier der originale Code:

Option Explicit
Dim AC As Range, wt As Integer
Dim Datum As Date, Bereich

Sub Stunden_auflisten()
Dim ESPl As Worksheet, ze As Integer
Set ESPl = Worksheets("Einsatzplanung")

With Worksheets("Auswertung")
     .Range("A3:D300").ClearContents
     Application.ScreenUpdating = False
     ze = 4   '1. Zeile zum auflisten
    
     'Einsatzplanung Bereich laden
     Bereich = "A4:A19":  GoSub Liste
     Bereich = "A23:A38": GoSub Liste
     Bereich = "A42:A57": GoSub Liste
     Bereich = "A61:A76": GoSub Liste
     Bereich = "A80:A95": GoSub Liste
Exit Sub

Liste: 'Wochenplan Blockweise auflisten
    'Wochentage Blockweise abarbeiten
    For wt = 2 To 15 Step 2
      'Wochentage Montag - Sonntag  auswerten
      For Each AC In ESPl.Range(Bereich).Offset(0, wt)
          If AC = "" Or LCase(AC) = "geschlossen" Then
          ElseIf Not IsNumeric(Left(AC, 1)) Then
             Datum = ESPl.Cells(3, wt + 3)
             .Cells(ze, 1) = Datum           'Datum
             .Cells(ze, 2) = AC.Cells(1, 2)  'Ehrenamtler
             .Cells(ze, 3) = AC.Cells(2, 2)  'Stunden
             .Cells(ze, 4) = "  " & AC.Cells(1, 1)  'Aktion
              ze = ze + 1
          End If
      Next AC
    Next wt
    Return
End With
End Sub

Mit folgender Änderung habe ich es hinbekommen dass die Daten richtig ausgelesen werden, aber die Auswertung startet erst ab dem 03.01.24.

Option Explicit
Dim AC As Range, wt As Integer
Dim Datum As Date, Bereich

Sub Stunden_auflisten()
Dim ESPl As Worksheet, ze As Integer
Set ESPl = Worksheets("Einsatzplanung")

With Worksheets("Auswertung")
     .Range("A3:D300").ClearContents
     Application.ScreenUpdating = False
     ze = 4   '1. Zeile zum auflisten
    
     'Einsatzplanung Bereich laden
     Bereich = "A4:A19":  GoSub Liste
     Bereich = "A23:A38": GoSub Liste
     Bereich = "A42:A57": GoSub Liste
     Bereich = "A61:A76": GoSub Liste
     Bereich = "A80:A95": GoSub Liste
Exit Sub

Liste: 'Wochenplan Blockweise auflisten
    'Wochentage Blockweise abarbeiten
    For wt = 2 To 15 Step 2
      'Wochentage Montag - Sonntag  auswerten
      For Each AC In ESPl.Range(Bereich).Offset(0, wt + 2)
          If AC = "" Or LCase(AC) = "geschlossen" Then
          ElseIf Not IsNumeric(Left(AC, 1)) Then
             Datum = ESPl.Cells(3, wt + 3)
             .Cells(ze, 1) = Datum           'Datum
             .Cells(ze, 2) = AC.Cells(1, 2)  'Ehrenamtler
             .Cells(ze, 3) = AC.Cells(2, 2)  'Stunden
             .Cells(ze, 4) = "  " & AC.Cells(1, 1)  'Aktion
              ze = ze + 1
          End If
      Next AC
    Next wt
    Return
End With
End Sub

Die Excel könnt ihr euch hier ansehen: Dienstplan_Auswertung

Bei Unklarheiten gerne melden. Ansonsten schon mal vielen Dnak für eure Hilfe. :)