Loop Vergleich

Hallo zusammen,
ich habe gerade ein Problem mit einer Tabelle welche so ausschaut:
Tabelle 1: Tabelle 2:
12 I nein I nein I nein I nein I nein I I 14 I ja I nein I nein I ja I nein I
13 I nein I nein I nein I nein I nein I I 12 I ja I nein I nein I ja I nein I
14 I nein I nein I nein I nein I nein I I 13 I ja I ja I ja I ja I nein I
15 I nein I nein I nein I nein I nein I I 15 I ja I ja I nein I ja I nein I
Die "I" sollen die nächste Zelle andeuten.
Nun soll der Code folgendes können:
1. Zahl in Tabelle 1 definieren
2. In Tabelle 2 nach der definierten Zelle suchen
3. Wenn definierte Zelle in Tabelle 2 gefunden den Inhalt der Zellen kopieren
4. Den kopierten Inhalt in Tabelle 1 zu der definierten Zahl einfügen
Und das ganze soll Zeile für Zeile wiederholt werden.
Ich bedanke mich schonmal für eure Hilfe.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Übernehmen() Dim Z As Range Dim Q As Range Dim wsQ As Worksheet Dim wsZ As Worksheet With Worksheets("Tabelle1") For Each Z In wsZ.Range("A1:A10") Set Q = Worksheets("Tabelle2").Range("A:A").Find(what:=Z.Value) If Not Q Is Nothing Then If (Q.Offset(0, 1).Value = Z.Offset(0, 1).Value) _ And (Q.Offset(0, 2).Value = Z.Offset(0, 2).Value) _ And (Q.Offset(0, 3).Value = Z.Offset(0, 3).Value) _ And (Q.Offset(0, 4).Value = Z.Offset(0, 4).Value) _ And (Q.Offset(0, 5).Value = Z.Offset(0, 5).Value) Then Z.Resize(1, 6) = Q.Resize(1, 6).Value End If Next End With End Sub

Sub Übernehmen() Dim Z As Range Dim Q As Range Dim wsQ As Worksheet Dim wsZ As Worksheet Set wsZ = Worksheets("Tabelle2") Set wsQ = Worksheets("Tabelle1") With Worksheets("Tabelle1") For Each Z In wsZ.Range("A1:A10") Set Q = Worksheets("Tabelle2").Range("A1:A10").Find(what:=Z.Value) If Not Q Is Nothing Then If (Q.Offset(0, 1).Value = Z.Offset(0, 1).Value) _ And (Q.Offset(0, 2).Value = Z.Offset(0, 2).Value) _ And (Q.Offset(0, 3).Value = Z.Offset(0, 3).Value) _ And (Q.Offset(0, 4).Value = Z.Offset(0, 4).Value) _ And (Q.Offset(0, 5).Value = Z.Offset(0, 5).Value) Then Z.Resize(1, 6) = Q.Resize(1, 6).Value End If Next End With End Sub

den wsZ in der For-Zeile muss weg. es bleibt folgendes Übrig:


Sub Übernehmen()
Dim Z As Range
Dim Q As Range
With Worksheets("Tabelle1")
For Each Z In .Range("A1:A10")
Set Q = Worksheets("Tabelle2").Range("A1:A10").Find(what:=Z.Value)
If Not Q Is Nothing Then
If (Q.Offset(0, 1).Value = Z.Offset(0, 1).Value) _
And (Q.Offset(0, 2).Value = Z.Offset(0, 2).Value) _
And (Q.Offset(0, 3).Value = Z.Offset(0, 3).Value) _
And (Q.Offset(0, 4).Value = Z.Offset(0, 4).Value) _
And (Q.Offset(0, 5).Value = Z.Offset(0, 5).Value) Then Z.Resize(1, 6) = Q.Resize(1, 6).Value
End If
Next
End With
End Sub

Du hast Wahrscheinlich den wsZ durch Tabelle1 ersetzt:


Sub Übernehmen()
Dim Z As Range
Dim Q As Range
With Worksheets("Tabelle1")
For Each Z In Worksheets("Tabelle1").Range("A1:A10")
Set Q = Worksheets("Tabelle2").Range("A1:A10").Find(what:=Z.Value)
If Not Q Is Nothing Then
If (Q.Offset(0, 1).Value = Z.Offset(0, 1).Value) _
And (Q.Offset(0, 2).Value = Z.Offset(0, 2).Value) _
And (Q.Offset(0, 3).Value = Z.Offset(0, 3).Value) _
And (Q.Offset(0, 4).Value = Z.Offset(0, 4).Value) _
And (Q.Offset(0, 5).Value = Z.Offset(0, 5).Value) Then Z.Resize(1, 6) = Q.Resize(1, 6).Value
End If
Next
End With
End Sub

was unnötig wäre, weil Worksheets("Tabelle1") schon in dem abkürzenden "With" vorhanden ist.
Etwas was mit einem Punkt anfängt bedeutet "ich nehme die Abkürzung"
Die beide folgende Version sind absolut gleichwertig:


'v1: abgekurzt:
With Worksheets("Tabelle1")
.Range("A1") = .Range("C1").Value
.Range("A2") = .Range("C2").Value
End With
'v2: volle Länge und schwer lesbar
Worksheets("Tabelle1").Range("A1") = Worksheets("Tabelle1").Range("C1").Value
Worksheets("Tabelle1").Range("A2") = Worksheets("Tabelle1").Range("C2").Value

VG
Yal

Sub Übernehmen() Dim Z As Range Dim Q As Range With Worksheets("Tabelle1") For Each Z In .Range("A1:A10") Set Q = Worksheets("Tabelle2").Range("A1:A10").Find(what:=Z.Value) If Not Q Is Nothing Then Z.Resize(1, 6) = Q.Resize(1, 6).Value Next End With End Sub

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread