AW: Werte aus 2 Tabellen vergleichen und ggf. Spalten kopieren
14.08.2024 09:19:16
MCO
Moin!
Mittlerweile gibt´s ja durchaus andere Möglichkeiten für eine so simple Aufgabe. Die müsste doch schon ein Computer lösen können.... Ach! Guck an: eine KI!
Wenn du oben rechts auf das Schwarz hinterlegte Logo gehst, kannst du deinen beschreibenden Text schon eingeben und erhältst eine lauffähige Lösung inkl. Erklärung:
Sub WerteVergleichenUndKopieren()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim i As Long
Dim j As Long
' Arbeitsblätter definieren
Set ws1 = ThisWorkbook.Sheets("Tabelle1")
Set ws2 = ThisWorkbook.Sheets("Tabelle2")
' Letzte Zeile in beiden Tabellen bestimmen
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 7).End(xlUp).Row
' Durchlaufe alle Zeilen in Tabelle 2, Spalte G
For i = 2 To lastRow2
' Durchlaufe alle Zeilen in Tabelle 1, Spalte A
For j = 2 To lastRow1
' Vergleich der Werte
If ws2.Cells(i, 7).Value = ws1.Cells(j, 1).Value Then
' Wenn gleich, kopiere die Werte
ws1.Cells(j, 2).Value = ws2.Cells(i, 8).Value ' Kopiere H -> B
ws1.Cells(j, 3).Value = ws2.Cells(i, 9).Value ' Kopiere I -> C
ws1.Cells(j, 4).Value = ws2.Cells(i, 11).Value ' Kopiere K -> D
ws1.Cells(j, 5).Value = ws2.Cells(i, 12).Value ' Kopiere L -> E
ws1.Cells(j, 6).Value = ws2.Cells(i, 13).Value ' Kopiere M -> F
Exit For ' Beende die Schleife, wenn ein Match gefunden wurde
End If
Next j
Next i
MsgBox "Werte wurden erfolgreich kopiert!", vbInformation
End Sub
Allerdings bevorzuge ich es, nicht alle Daten immer wieder durchzuhecheln sondern gezielt zu suchen.
Daher hab ich die zweite Schleife eliminiert.
Sub WerteVergleichenUndKopieren2()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim i As Long
Dim j As Long
' Arbeitsblätter definieren
Set ws1 = ThisWorkbook.Sheets("Tabelle1")
Set ws2 = ThisWorkbook.Sheets("Tabelle2")
' Letzte Zeile in beiden Tabellen bestimmen
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 7).End(xlUp).Row
' Durchlaufe alle Zeilen in Tabelle 2, Spalte G
For i = 2 To lastRow2
' Durchlaufe alle Zeilen in Tabelle 1, Spalte A
Set gef = ws1.Range("A:A").Find(ws2.Cells(i, 7).Value)
If Not gef Is Nothing Then
j = gef.Row
' Wenn gleich, kopiere die Werte
ws1.Cells(j, 2).Value = ws2.Cells(i, 8).Value ' Kopiere H -> B
ws1.Cells(j, 3).Value = ws2.Cells(i, 9).Value ' Kopiere I -> C
ws1.Cells(j, 4).Value = ws2.Cells(i, 11).Value ' Kopiere K -> D
ws1.Cells(j, 5).Value = ws2.Cells(i, 12).Value ' Kopiere L -> E
ws1.Cells(j, 6).Value = ws2.Cells(i, 13).Value ' Kopiere M -> F
End If
Next i
MsgBox "Werte wurden erfolgreich kopiert!", vbInformation
End Sub
Wenn du noch weiter optimieren möchtest, könntest du den bereich der ersten Schleife weiter auf nichtleere Zellen einschränken.
Siehe dazu .specialcells(xlconstants) . Auch da wird die KI bei der Umsetzung helfen.
Gruß, MCO