Sub speicher()
On Error GoTo Fehler
Dim wkb As Workbook, wkbNeu As Workbook, wks As Worksheet, wksTmp As Worksheet, wksNeu As Worksheet
Dim i As Integer, LR As Integer
Dim Arr()
Dim Pfad As String, Dateiname As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wkb = ThisWorkbook
Set wks = wkb.ActiveSheet
Pfad = wks.Range("I4")
Dateiname = wks.Range("I23")
If wks.AutoFilterMode Then wks.AutoFilterMode = False
Set wksTmp = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
With wksTmp
wks.Columns(4).Copy .Columns(1)
.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
Arr = .Range(.Cells(2, 1), .Cells(LR, 1))
End With
Set wkbNeu = Workbooks.Add
For i = LBound(Arr) To UBound(Arr)
Set wksNeu = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
wks.Columns(4).AutoFilter Field:=1, Criteria1:=Arr(i, 1)
wks.Columns(1).Resize(, 3).Copy wksNeu.Columns(1).Resize(, 3)
wksNeu.Name = Arr(i, 1)
wksNeu.Move after:=wkbNeu.Sheets(wkbNeu.Sheets.Count)
Next
wks.AutoFilterMode = False
Application.DisplayAlerts = False
wksTmp.Delete
wkbNeu.SaveAs Filename:=Pfad & "\" & Dateiname & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wkbNeu.Close
Err.Clear
Fehler:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub