Hallo Dennis,

ich habe das nochmal etwas umgeschrieben. Jetzt werden alle Codes mit übernommen, auch der ausführende. Haupttabelle muss dabei das einzige Blatt in der Master-Datei sein. Probier mal den neuen Code:

Option Explicit
Sub Anlegen()
 
 Dim Dateiname As String, Pfad As String
 Dim y As Variant, dt As Date, wk As Byte, t As Byte, f As Boolean, Tag As String, x As Byte
 
 Do
 y = InputBox("Geben Sie ein Jahr zwischen 2000 und 2099 ein")
 Loop Until y >= 2000 And y <= 2099 Or y = ""
 If y = "" Then Exit Sub
 
 Pfad = InputBox("Geben Sie einen Speicherpfad an.", "Datei anlegen", ActiveWorkbook.Path)
 If Pfad = "" Then Exit Sub
 
 On Error Resume Next
 MkDir Pfad
 On Error GoTo 0
 
 dt = CDate("01.01." & y)
 wk = DatePart("ww", dt, vbMonday, vbUseSystem)
 If wk = 53 Then f = True
 
 Do While dt <= CDate("31.12." & y)
   t = DatePart("w", dt, vbMonday)
   Tag = Choose(t, "Mo", "Di", "Mi", "Do", "Fr", "Sa", "So")
   
   If dt = CDate("01.01." & y) Or t = 1 Then
     wk = DatePart("ww", dt, vbMonday, vbUseSystem)
     Dateiname = "KW_" & IIf(wk < 10, "0", "") & wk & "_" & IIf(f, y - 1, y)
     ThisWorkbook.SaveAs Pfad & "\" & Dateiname, xlOpenXMLWorkbookMacroEnabled
     ActiveWorkbook.Sheets(1).Name = Tag & " " & dt
     ActiveWorkbook.Sheets(1).Range("A1") = Dateiname
     ActiveWorkbook.Sheets(1).Range("B1") = dt
     ActiveWorkbook.Sheets(1).Range("B1").NumberFormat = "ddd dd.mm.yyyy"
   Else
     If t > Sheets.Count Then
       ActiveWorkbook.Sheets(1).Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
       x = Sheets.Count
     Else
       x = t
     End If
     ActiveWorkbook.Sheets(x).Name = Tag & " " & dt
     ActiveWorkbook.Sheets(x).Range("A1") = Dateiname
     ActiveWorkbook.Sheets(x).Range("B1") = dt
     ActiveWorkbook.Sheets(x).Range("B1").NumberFormat = "ddd dd.mm.yyyy"
   End If
   
   If t = 7 Or dt = CDate("31.12." & y) Then
     ActiveWorkbook.Save
     f = False
   End If
 dt = dt + 1
 Loop
 
 If x < 7 Then
 Application.DisplayAlerts = False
 For t = 0 To 7 - (x + 1)
   Sheets(7 - t).Delete
 Next t
 ActiveWorkbook.Save
 Application.DisplayAlerts = True
 End If
 
End Sub

Gruß Mr. K.