Clever-Excel-Forum

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

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 Smile

BadHabiit

schauan