Sub Speichern()
Dim FileName As String
Dim Path As String, Pathu As String
Dim wb As Workbook, ws As Worksheet
Dim Ini As Integer, Nbr As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Path = "R:\02_PM_ZAM\Tools\Tools_Einkauf\OutOfStock_Ablage\OutOfStock_PG"
Pathu = "R:\02_PM_ZAM\Tools\Tools_Einkauf\OutOfStock_Ablage\OutOfStock_PG"
Jahr = Format(DateSerial(Year(Now()), Month(Now()), 1), "YYYY")
lng = 10
Ini = 1
For Each ws In wb.Sheets
Set ws = Sheets(Ini)
FileName = ws.Name
Path = Path & " " & lng & "\"
If Dir(Path, vbDirectory) = "" Then
MkDir Path
End If
Path = Path & Jahr & "\"
If Dir(Path, vbDirectory) = "" Then
MkDir Path
End If
Debug.Print Path
Path = Path & FileName & ".xlsx"
ws.Copy
Debug.Print Path
With ActiveWorkbook
.SaveAs FileName:=Path, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close SaveChanges:=False
End With
lng = lng + 10
Path = Pathu
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub