Office: zelleninhalt kopieren wenn bedingung erfüllt

Hallo,
Ich versuche gerade per VBA zellenbereiche bei erfülte bedingung zu kopieren.

Zu suchende bereich ist „B : D“
Die Spalte ist „D“ kann werte 1-5 haben

Erklärung:
Alle zellenbereiche mit D“1“ soll nach Tabelle 2 C2…. Kopiert werden.
Alle zellenbereiche mit D“2“ soll nach Tabelle 2 G3…. Kopiert werden.
Alle zellenbereiche mit D“3“ soll nach Tabelle 2 K4…. Kopiert werden.
Alle zellenbereiche mit D“4“ soll nach Tabelle 2 O5…. Kopiert werden.
Alle zellenbereiche mit D“5“ soll nach Tabelle 2 S6…. Kopiert werden.

Mein erste versuch lautet:

PHP:

         Option Explicit
Sub Kopieren()
Dim a As Long
Dim i As Long
Dim wrsQuelle As Worksheet
Set wrsQuelle = Worksheets("Tabelle1")
Dim wrsZiel As Worksheet
Set wrsZiel = Worksheets("Tabelle2")
Application.ScreenUpdating = False
a = 2
For i = 1 To 999
If wrsQuelle.Cells(i, "D") = "1" Then
wrsQuelle.Rows(i).Copy Destination:=wrsZiel.Rows(a)
a = a + 1
End If
Next i
Set wrsQuelle = Nothing
Set wrsZiel = Nothing
Application.ScreenUpdating = True
End Sub


:)

 

Hallo fados,

mein Vorschlag:
Code:

Gruß
Aloys

 

Super, es Funktioniert so wie ich es brauche.

Danke