Liebe Leute,

ich bin langsam am Verzweifeln. Hier mein Programm:

posNo(1) = "0000"
    posNo(2) = "9"
    posNo(3) = "0301"
    posNo(4) = "0302"
    posNo(5) = "x" '"0305"
    posNo(6) = "x" '"0320"
    posNo(7) = "0341"
    posNo(8) = "0342"
    posNo(9) = "x" '"0345"
    posNo(10) = "0360"
    posNo(11) = "0381"
    posNo(12) = "0382"
    posNo(13) = "0401"
    posNo(14) = "0402"
    posNo(15) = "0451"
    posNo(16) = "0452"
    posNo(17) = "x" '"0465"
    posNo(18) = "x" '"0466"
    posNo(19) = "x" '"0467"
    posNo(20) = "x" '"0468"
    posNo(21) = "0471"
    posNo(22) = "0472"
    posNo(23) = "0481"
    posNo(24) = "0482"
    
    Worksheets(1).Activate
    
    counter = 0
    
    With Worksheets(1).Range("a2:a" & lastRow)
    
        Set rng = .Find(9, LookIn:=xlValues)
    
        If Not rng Is Nothing Then
    
            firstAddress9 = rng.Address
        
            Do
                
                counter = counter + 1
                
                Set rng = .FindNext(rng)
                
                If rng Is Nothing Then
                
                    GoTo DoneFinding9
                    
                End If
                
                Loop While Not rng Is Nothing And rng.Address <> firstAddress9
                
        End If
    
DoneFinding9:
    End With
    
    
    For counterVar = 1 To counter
        For controlVar = 1 To 24
        With Worksheets(1).Range("a2:a" & lastRow)
        Set rng = Nothing
        Set rng = .Find(posNo(controlVar), LookIn:=xlValues)
        
        MsgBox posNo(controlVar)
        
    
        If Not rng Is Nothing Then
    
            firstAddress = rng.Address
        
            Do
                
                MsgBox rng
                
                rng.Select
                cellRow = ActiveCell.Row
                cellColumn = ActiveCell.Column
                Cells(cellRow, cellColumn).EntireRow.Select
            
                Selection.Cut
                Sheets("Etikettenformate").Select
            
                lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                Cells(lastRow, 1).Select
                ActiveSheet.Paste
                
                Worksheets(1).Activate
                lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
                x = counterVar * controlVar
                Range("a2:a" & lastRow).Select
                
                If rng Is Nothing Then
                
                    GoTo DoneFinding
                    
                End If
                
                Loop While Not rng Is Nothing And rng.Address <> firstAddress
                
        End If
    
DoneFinding:
        End With
        Next controlVar
    Next counterVar

Und täglich grüßt das Autofilter ;-))))))))))))

Option Explicit

Sub ADemo()
Dim posNo(1 To 24), Arr()
posNo(1) = "0000"
posNo(2) = "9"
posNo(3) = "0301"
posNo(4) = "0302"
posNo(5) = "x" '"0305"
posNo(6) = "x" '"0320"
posNo(7) = "0341"
posNo(8) = "0342"
posNo(9) = "x" '"0345"
posNo(10) = "0360"
posNo(11) = "0381"
posNo(12) = "0382"
posNo(13) = "0401"
posNo(14) = "0402"
posNo(15) = "0451"
posNo(16) = "0452"
posNo(17) = "x" '"0465"
posNo(18) = "x" '"0466"
posNo(19) = "x" '"0467"
posNo(20) = "x" '"0468"
posNo(21) = "0471"
posNo(22) = "0472"
posNo(23) = "0481"
posNo(24) = "0482"

Dim Rng As Range, x

   With Worksheets(1)
      If .AutoFilterMode Then Cells.AutoFilter
      Set Rng = .UsedRange
      Rng.AutoFilter Field:=1, Criteria1:=posNo, Operator:=xlFilterValues
      Set Rng = Rng.SpecialCells(12)
      For x = 2 To Rng.Areas.Count
         Rng.Areas(x).Copy Sheets("Etikettenformate").Cells(Rows.Count, 1).End(xlUp).Offset(1)
      Next x
      For x = Rng.Areas.Count To 2 Step -1
         Rng.Areas(x).EntireRow.Delete
      Next x
      .Cells.AutoFilter
      
   End With

End Sub