Hallo Dennis,

versuch mal testweise folgenden Code. Sollte bei dir ein Fehler kommen, ersetze 

ActiveWorkbook.SaveAs Pfad & "\" & Dateiname

durch

ActiveWorkbook.SaveAs Pfad & "\" & Dateiname, xlOpenXMLWorkbook

Hier nun der Code:

Option Explicit
Sub Anlegen()
 
 Dim Blatt As Worksheet, 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, z As Byte
 
 Set Blatt = ThisWorkbook.Sheets("Haupttabelle") 'Blatt zum Kopieren
  
 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)
     z = 1
     Dateiname = "KW_" & IIf(wk < 10, "0", "") & wk & "_" & IIf(f, y - 1, y)
     Blatt.Copy
   Else
     Blatt.Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
   End If
   
   ActiveWorkbook.Sheets(Sheets.Count).Name = Tag & " " & dt
   ActiveWorkbook.Sheets(Sheets.Count).Range("A1") = Dateiname
   ActiveWorkbook.Sheets(Sheets.Count).Range("B1") = dt
   ActiveWorkbook.Sheets(Sheets.Count).Range("B1").NumberFormat = "ddd dd.mm.yyyy"
   
   If t = 7 Or dt = CDate("31.12." & y) Then
     
     ActiveWorkbook.SaveAs Pfad & "\" & Dateiname
     ActiveWorkbook.Close
     f = False
   End If
 dt = dt + 1
 z = z + 1
 Loop
 

End Sub

Gruß Mr. K.