Option Explicit
Sub Main()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wkbBook As Workbook
Dim lngLastTMP As Long
Dim lngLastRow As Long
Dim lngCalc As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set wksQuellSheet = Worksheets("Detail")
Set wksKriterienSheet = Worksheets.Add
wksKriterienSheet.Move After:= _
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
With wksQuellSheet
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
End With
wksQuellSheet.Range("BG1:BG" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
Set rngKriterium = wksKriterienSheet.Range("A2")
While rngKriterium.Value <> ""
Set wksNew = Worksheets.Add
wksQuellSheet.Range("A1:FK" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1"), Unique:=True
wksNew.Name = rngKriterium.Text & "_" & "_" & wksQuellSheet.Cells(2, 60)
rngKriterium.EntireRow.Delete
wksNew.Copy
Set wkbBook = ActiveWorkbook
If Val(Application.Version) < 12 Then
wkbBook.SaveAs ThisWorkbook.Path & _
Application.PathSeparator & wksNew.Name & ".xls"
Else
wkbBook.SaveAs ThisWorkbook.Path & _
Application.PathSeparator & wksNew.Name, 56
End If
wkbBook.Close SaveChanges:=False
Set wkbBook = Nothing
wksNew.Delete
Set wksNew = Nothing
Set rngKriterium = Nothing
Set rngKriterium = wksKriterienSheet.Range("A2")
Wend
wksKriterienSheet.Delete
Set wksKriterienSheet = Nothing
Fin:
If Not wkbBook Is Nothing Then wkbBook.Close SaveChanges:=False
If Not wksNew Is Nothing Then wksNew.Delete
If Not wksKriterienSheet Is Nothing Then wksKriterienSheet.Delete
Set wkbBook = Nothing
Set wksKriterienSheet = Nothing
Set wksQuellSheet = Nothing
Set rngKriterium = Nothing
Set wksNew = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = lngCalc
.DisplayAlerts = True
.CutCopyMode = True
End With
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub