Option Explicit
Sub Test()
Const QUELLE As String = "Lager gesamt"
Dim RngAD As Range
Dim arrAD() As Variant
Dim i As Integer
Dim oWsh As Excel.Worksheet
Dim oWs As Excel.Worksheet
Dim RngDest As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each oWsh In ThisWorkbook.Sheets
If oWsh.Name <> QUELLE Then oWsh.Delete
Next oWsh
With Sheets(QUELLE)
Set RngAD = .UsedRange
Set RngAD = Range(RngAD.Columns(1), RngAD.Columns(4))
arrAD = RngAD
End With
For i = 10 To 22
Set oWsh = Worksheets.Add(After:=Sheets(Sheets.Count))
Sheets(QUELLE).Columns(i).Copy ActiveSheet.Cells(1, 5)
Sheets(QUELLE).Columns(23).Copy ActiveSheet.Cells(1, 6)
Set oWs = Worksheets.Add(After:=Sheets(Sheets.Count))
With oWsh
With .Cells(1, 5).CurrentRegion
.AutoFilter Field:=2, Criteria1:="=A", Operator:=xlOr, Criteria2:="=B"
.SpecialCells(xlCellTypeVisible).Copy oWs.Cells(1, 5)
End With
.Delete
End With
With oWs
.Name = Cells(1, 5).Value
Set RngDest = .Range("A1")
RngDest.Resize(UBound(arrAD, 1), UBound(arrAD, 2)).Value = arrAD
End With
Next i
For i = 19 To 22
Set oWsh = Worksheets.Add(After:=Sheets(Sheets.Count))
Sheets(QUELLE).Columns(i).Copy ActiveSheet.Cells(1, 5)
Sheets(QUELLE).Columns(23).Copy ActiveSheet.Cells(1, 6)
Set oWs = Worksheets.Add(After:=Sheets(Sheets.Count))
With oWsh
With .Cells(1, 5).CurrentRegion
.AutoFilter Field:=2, Criteria1:="=C"
.SpecialCells(xlCellTypeVisible).Copy oWs.Cells(1, 5)
End With
.Delete
End With
With oWs
.Name = Cells(1, 5).Value & "C"
Set RngDest = .Range("A1")
RngDest.Resize(UBound(arrAD, 1), UBound(arrAD, 2)).Value = arrAD
End With
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub