Hallo zusammen

dank eurer Hilfe habe ich eine funktionierende VBA-Programmierung für das Vergleichen der Werte von Spalte A, Tabelle 2, mit den Werten der Spalte R, Tabelle 1. Sofern der Wert gleich ist, werden die Zellen B - F der Tabelle 2 neben dem entsprechenden Wert kopiert und in Spalte S - W der Tabelle 1 kopiert.

Dies funktioniert alles Bestens! Jedoch kommt es vor, dass ein Wert mehrmals in der Spalte R vorkommen kann und durch das VBA sollte bei jedem Wert die vorgenannten Zellen eingefügt werden. Mit der bestehenden VBA wird jeweils nur beim obersten Wert (der gleichen Werte) die Zellen eingefügt.

Sub WerteVergleichenUndKopieren2()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim werte_rng As Range
Dim Wert As Range

' Arbeitsblätter definieren
Set ws1 = ThisWorkbook.Sheets("Tabelle1")
Set ws2 = ThisWorkbook.Sheets("Tabelle2")
Set werte_rng = ws2.Range("A:A").SpecialCells(xlConstants)

' Durchlaufe alle werte_rng in Tabelle 2, Spalte A
For Each Wert In werte_rng

i = Wert.Row
Set gef = ws1.Range("R:R").Find(what:=Wert, LookIn:=xlValues, lookat:=xlWhole) ' Findet alle Werte in Tabelle 1, Spalte R
If Not gef Is Nothing Then
Wert.Interior.Color = vbGreen
j = gef.Row
' Wenn gleich, kopiere die Werte
ws1.Cells(j, 19).Value = ws2.Cells(i, 2).Value ' Kopiere B -> S
ws1.Cells(j, 20).Value = ws2.Cells(i, 3).Value ' Kopiere C -> T
ws1.Cells(j, 21).Value = ws2.Cells(i, 4).Value ' Kopiere D -> U
ws1.Cells(j, 22).Value = ws2.Cells(i, 5).Value ' Kopiere E -> V
ws1.Cells(j, 23).Value = ws2.Cells(i, 6).Value ' Kopiere F -> W
Else 'nicht gefunden!
fehl_txt = fehl_txt & Chr(10) & Wert & " nicht gefunden"
Wert.Interior.Color = vbRed
End If
Next Wert

If fehl_txt > "" Then
MsgBox fehl_txt, vbCritical
Else
MsgBox "Werte wurden erfolgreich kopiert!", vbInformation
End If
End Sub

Hat jemand eine Idee wie ich den VBA anpassen kann, dass wenn der Wert in der Spalte R der Tabelle 1 mehrmals vorkommt, die entsprechenden Zellen aus Tabelle 2 entsprechend mehrmals kopiert werden?

Besten Dank für eure Hilfe!

Gruss

Olli