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.
|