Herbers Excel/VBA-Archiv

    Private Sub CommandButton18_Click()
    Dim Pfad As String, Jahr As String, Monat As String
    Dim daDatum As Date, i As Long, loZähler As Long, sh As Shape
    Dim mldg As Variant, Quelle As String, Ziel As String
    
    Application.ScreenUpdating = False
    
    'Prüfung ob alle Stärkemeldungen erfasst sind
    For i = 1 To 12
        If Me.Controls("Commandbutton" & i).BackColor = vbGreen Then
            loZähler = loZähler + 1
        End If
    Next i
    
    If Me.CommandButton15.BackColor = vbGreen Then loZähler = loZähler + 1
    
    'Datu aus Zelleholen
    daDatum = Range("L3")
    
    If loZähler < 13 Then
        mldg = MsgBox("Fehler: Unzulässig, es sind noch nicht alle Särkemeldungen erfasst." _
        , , "Hinweis für " & Application.UserName)
        Exit Sub
    Else
        If MsgBox("Sind alle Stärkemeldungen" & vbLf & "für den " & daDatum _
            & " bereits erfasst?", vbYesNo, "Sicherheitsabfrage an " _
            & Application.UserName) = vbYes Then
            
            'Userform ausblenden
            Start.Hide
            'neues Datum für Folgetag erstellen
            Jahr = Year(daDatum + 1)
            Monat = Format(daDatum + 1, "MM") & "-" & Format(daDatum + 1, "MMMM")
            Worksheets("Tabelle1").Range("D1") = "Abschluß"
            ThisWorkbook.Save
            
            '# Pfad zur aktuellen Datei anpassen ##
            Pfad = "P:\Stärke\" & Jahr & "\"    '##
            '######################################
            
            'Quelldatei festlegen = Datei des aktuellen Tages
            Quelle = ThisWorkbook.Path & "\" & daDatum & ".xlsm"
            
            'ggf. neuen Jahresordner und/oder neuen Monatsordner anlegen
            If Dir(Pfad, vbDirectory) = "" Then
                MkDir (Pfad)
            End If
    
            Pfad = Pfad & Monat & "\"
    
            If Dir(Pfad, vbDirectory) = "" Then
                MkDir (Pfad)
            End If
            
            'aktuelle .xlsm als .xlsx speichern
            Application.DisplayAlerts = False
            With ThisWorkbook
                .Worksheets("Personal").Delete
                .Worksheets("Tabelle1").Range("D1").ClearContents
                .Worksheets("Tabelle1").Columns("N:U").ClearContents
                For Each sh In .Worksheets("Tabelle1").Shapes
                    sh.Delete
                Next sh
                .SaveAs Filename:=ThisWorkbook.Path & "\" & daDatum & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook
                
                'aktuelle .xlsm umbenennen (neuer Tag)
                'und ggf. in neuen Ordner verschieben
                On Error GoTo Ausgang
                Ziel = Pfad & daDatum + 1 & ".xlsm"
                Name Quelle As Ziel
                mldg = MsgBox("Die Datei für den " & daDatum + 1 & " wurde erfolgreich angelegt." _
                , , "Hinweis für " & Application.UserName)
                .Close False
            End With
            Application.DisplayAlerts = True
            
            'aktive Datei speichern und schließen
            ThisWorkbook.Close True
            'Excel beenden
            Application.Quit
        End If
    End If
    Exit Sub
    
    Ausgang:
    MsgBox "Es ist ein Fehler aufgetreten." & vbLf _
    & "Die Datei für den neuen Tag konnte nicht angelegt werden." _
    & vbLf & vbLf & "Bitte die Datei ""Vorlage Stärkemeldung"" aus dem Hauptverzeichnis öffnen." _
    & vbLf & "Anschließend die Datei mit ""Speichern unter... im entsprechenden Monat" _
    & vbLf & "unter dem Datum des neu anzulegenden Tages abspeichern." & vbLf _
    & "Datumsformat: XX.XX.XXXX"
    End Sub