Spalte nach Werten durchsuchen & alle Zellen des gefunden Wertes in jeweiliges Sheet

[BadHabiit]

Hallo zusammen,

Kann mir einer aus diesem Code eine Schleife basteln, damit ich nicht jeden einzelnen Wert abfragen muss.
Vielen Dank schonmal :)

Ich hab eine Spalte mit bestimmten Werten. Aus diesen Werten werden dann automatisch Sheets generiert.
Jetzt möchte ich gerne alle Zellen bei denen dieser Wert vorkommt in das jeweilige Sheet kopieren

Code:

Public Sub filterdata()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

With Sheets(1)
   For i = 2 To 1000
       If .Cells(i, 1).Value = "WIESB" Then
           .Cells(i, 1).EntireRow.Copy
           Sheets("WIES").Cells(2, 1 + 1).EntireRow.Insert
       End If
   Next i
End With

'UK

With Sheets(1)
   For i = 2 To 1000
       If .Cells(i, 1).Value = "UK" Then
           .Cells(i, 1).EntireRow.Copy
Sheets("UK").Cells(2, 1 + 1).EntireRow.Insert
           
       End If
   Next i
End With

'TURK

With Sheets(1)
   For i = 2 To 1000
       If .Cells(i, 1).Value = "TURK" Then
           .Cells(i, 1).EntireRow.Copy
Sheets("TURK").Cells(2, 1 + 1).EntireRow.Insert

           
       End If
   Next i
End With

'Für diese Werte gibt es keinen eigenen Sheet
'Die Zellen mit diesem Wert sollen alle in das Sheet "SWA"
'SWA
With Sheets(1)
    For i = 2 To 1000
        If .Cells(i, 1).Value = "AF" Or _
        .Cells(i, 1).Value = "QA" Or _
        .Cells(i, 1).Value = "AE" Or _
        .Cells(i, 1).Value = "SA" Or _
        .Cells(i, 1).Value = "EG" Or _
        .Cells(i, 1).Value = "JO" Or _
        .Cells(i, 1).Value = "IQ" Or _
        .Cells(i, 1).Value = "KW" Then
        .Cells(i, 1).EntireRow.Copy
        Sheets("SWA").Cells(2, 1 + 1).EntireRow.Insert
            
        End If
    Next i
End With

Folgendes habe ich bereits versucht ohne Erfolg

Code:

Sub filterdatatest()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Region As Range
Dim i As Integer

With Sheets(1)
   For i = 2 To 1000
   For Each Region In Sheets(2).Range("G3:G100")
       If .Cells(i, 1).Value = Region Then
           .Cells(i, 1).EntireRow.Copy
           Sheets(Region).Cells(2, 1 + 1).EntireRow.Insert
       End If
Next
End With

 'Zwischenablage leeren
 Application.CutCopyMode = False
 'Zwischenablage leeren
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[schauan]

Hallöchen,

ohne Bewertung, ob Dein Code das richtige tut, mal ein Fehlerhinweis.

Zum einen fehlt ein Next.

Zum Anderen:
Sheets(Region).Cells(2, 1 + 1).EntireRow.Insert
1 + 1 wäre dann übrigens auch zwei, könnte man guten Gewissens auch gleich hin schreiben .