hi MATTHIAS,

mal zum Testen - etwas umständlich und ohne Fehlerbehandlung

'***************************************
' Quelltabellenname ANPASSEN!
Const QUELLE As String = "Lager gesamt"
'***************************************

Option Explicit

Sub Test()
'***************************************
' Quelltabellenname ANPASSEN!
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
'

'wegen Test
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each oWsh In ThisWorkbook.Sheets
   If oWsh.Name <> QUELLE Then oWsh.Delete
Next oWsh

'Testende
'
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
         '.Activate
         With .Cells(1, 5).CurrentRegion
            .AutoFilter Field:=2, Criteria1:="=A", Operator:=xlOr, Criteria2:="=B"
            .SpecialCells(xlCellTypeVisible).Copy oWs.Cells(1, 5)
            '.AutoFilter
         End With
         .Delete
      End With
      With oWs
         '.Activate
         .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
         '.Activate
         With .Cells(1, 5).CurrentRegion
            .AutoFilter Field:=2, Criteria1:="=C"
            .SpecialCells(xlCellTypeVisible).Copy oWs.Cells(1, 5)
            '.AutoFilter
         End With
         .Delete
      End With
      With oWs
         '.Activate
         .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