PDA

Vollständige Version anzeigen : zelleninhalt kopieren wenn bedingung erfüllt


fados
01.12.2016, 15:22
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: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

Für eure Hilfe wäre ich dankbar

aloys78
01.12.2016, 17:15
Hallo fados,

mein Vorschlag:
Option Explicit
Option Base 1

Sub Kopieren()
Dim q As Long 'Zeile Quelle
Dim z() As Variant 'Zeilen# Ziel
Dim s() As Variant 'Spalten-Buchstaben Ziel
Dim i As Long 'index Arrays
Dim wrsQuelle As Worksheet
Dim wrsZiel As Worksheet

Set wrsQuelle = Worksheets("Tabelle1")
Set wrsZiel = Worksheets("Tabelle2")
z = Array(1, 2, 3, 4, 5)
s = Array("C", "G", "K", "O", "S")
Application.ScreenUpdating = False

With wrsQuelle
For q = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
If IsNumeric(Range("D" & q)) Then i = CLng(Range("D" & q))
If i < 1 Or i > 5 Then
MsgBox "Ungültiger Wert i Spalte D !", vbCritical
GoTo Ende
End If
z(i) = z(i) + 1 ' Zeilen# Ziel
.Range("B" & q & ":D" & q).Copy
wrsZiel.Cells(z(i), s(i)).PasteSpecial Paste:=xlPasteValues
Next q
End With

Ende:
Set wrsQuelle = Nothing
Set wrsZiel = Nothing
Application.ScreenUpdating = True
End Sub
Gruß
Aloys

fados
04.12.2016, 13:49
Hallo fados,

mein Vorschlag

Super, es Funktioniert so wie ich es brauche.

Danke