Vergleich 2 Tabellen Makro

Hallo Leute,
erstmal vorneweg; habe leider mit Programmierung nicht soo viel Erfahrung, vor ca. einem Jahr habe ich aber in einem Uni Kurs C# ein bisschen kennengelernt.
Habe hier schon etwas mitgelesen, aber leider noch niemanden mit genau der gleichen Fragestellung gefunden:
Ich muss 2 Tabellen vergleichen und bei gefundenen Unterschieden die ganze Zeile in ein 3tes Tabellenblatt kopieren. Denke das lässt sich am besten per Makro lösen.
Habe etwas weiter unten eine ähnliche Fragestellung gefunden (von Dauth: https://www.herber.de/forum/messages/1505034.html), allerdings muss in meinen Tabellen jede Spalte einer Zeile mit den dazugehörigen Spalten der dazugehörigen Zeile verglichen werden, sprich die Unterschiede können in jeder Spalte auftreten und sollten auch dementsprechend untersucht werden.
Im Detail sieht das so aus;
In der Arbeitsmappe befinden sich 3 Tabellenblätter, "Input_alt", "Input_neu" und "Output". "Input_alt" und "Input_neu" sollen miteinander verglichen werden und bei jedem Unterschied (Wert in irgendeiner Spalte anders, Zeile nur in "Input_neu", Zeile nur in "Input_alt", usw.) die gesamte Zeile in das 3te Tabellen "Output" kopiert werden.
Jede Zeile hat eine einzigartige ID, d.h. neue und fehlende IDs können sofort kopiert werden. leider ändert sich die ID aber nicht wenn sich nur ein Wert ändert.
Im Beitrag von Dauth hat Christian schon einen verständlichen Code gepostet, der funktioniert bei mir recht gut, allerdings werden dort immer nur die Werte in einer bestimmten Spalte verglichen.
Ich denke bei mir müsste man eine 2te Laufvariable für die Spalten hinzufügen, die für jede betrachtete Zeile durchläuft und das Programm erst dann in die nächste Zeile springt.
Habe das schon selbst versucht, leider komme ich da nicht so recht auf einen grünen Zweig. Im Anhang findet ihr eine Beispieldatei, in diesem Fall sollte das Output Zeilen 1, 3, 4, 11, 12 und 18 umfassen.
Ich danke euch schonmal für die Hilfe!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Abgleich() Dim maxRN As Integer Dim maxRA As Integer Dim wsN As Worksheet Dim wsA As Worksheet Dim wsZ As Worksheet Dim i, iii As Long Set wsN = ThisWorkbook.Worksheets("Input_neu") Set wsA = ThisWorkbook.Worksheets("Input_alt") Set wsZ = ThisWorkbook.Worksheets("Output") maxRN = wsN.Cells(wsN.Rows.Count, 1).End(xlUp).Row maxRA = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row Call Weg(wsZ) For i = 2 To maxRN For iii = 1 To 15 If IstDa(wsN.Cells(i, iii), wsA, iii) = False Then wsN.Cells(i, iii).EntireRow.Copy Destination:=wsZ.Cells((wsZ.Rows.Count), iii). _ _ End(xlUp).Offset(1, 0).EntireRow End If Next iii Next i For i = 2 To maxRA For iii = 1 To 15 If IstDa(wsA.Cells(i, iii), wsN, iii) = False Then wsA.Cells(i, iii).EntireRow.Copy Destination:=wsZ.Cells((wsZ.Rows.Count), iii). _ _ End(xlUp).Offset(1, 0).EntireRow End If Next iii Next i End Sub Private Function IstDa(ByRef ArtID As String, ByRef ws As Worksheet, iii) As Boolean Dim i As Long For i = 2 To ws.Cells(ws.Rows.Count, iii).End(xlUp).Row If ArtID = ws.Cells(i, iii) Then IstDa = True Exit Function End If Next IstDa = False End Function Private Sub Weg(ws As Worksheet) ws.Range("A2:" & Cells(Rows.Count - 1, Columns.Count).Address).Clear End Sub

Sub Test() Dim oDictIDneu As Object, oDictIDalt As Object, oDictIDout As Object Dim maxRN As Integer Dim maxRA As Integer Dim wsN As Worksheet Dim wsA As Worksheet Dim wsZ As Worksheet Dim i, iii As Long Dim key Set oDictIDneu = CreateObject("Scripting.dictionary") Set oDictIDalt = CreateObject("Scripting.dictionary") Set oDictIDout = CreateObject("Scripting.dictionary") oDictIDout.RemoveAll oDictIDalt.RemoveAll oDictIDneu.RemoveAll Set wsN = ThisWorkbook.Worksheets("Input_neu") Set wsA = ThisWorkbook.Worksheets("Input_alt") Set wsZ = ThisWorkbook.Worksheets("Output") maxRN = wsN.Cells(wsN.Rows.Count, 1).End(xlUp).Row maxRA = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row Call Weg(wsZ) For i = 2 To maxRN If Not oDictIDneu.exists(wsN.Cells(i, 1).Value) Then oDictIDneu.Add wsN.Cells(i, 1), i 'Hier wird die ID mit der _ Zeilennummer eingetragen. Else x = MsgBox(wsN.Cells(i, 1) & "ist doppelt in der Tabelle NEu enthalten", vbOKOnly, " _ Doppelte Werte") End If Next i For i = 2 To maxRA If Not oDictIDalt.exists(wsA.Cells(i, 1).Value) Then oDictIDalt.Add wsA.Cells(i, 1), i 'Hier wird die ID mit der _ Zeilennummer eingetragen. Else x = MsgBox(wsN.Cells(i, 1) & "ist doppelt in der Tabelle NEu enthalten", vbOKOnly, " _ Doppelte Werte") End If Next i 'Alle nicht enthaltenen IDs der alten Tabelle werden übertragen. For Each key In oDictIDalt If Not oDictIDneu(key).exists And Not oDictIDout(key).exists Then wsA.Cells(oDictIDalt(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ.Rows.Count) _ , 1).End(xlUp).Offset(1, 0).EntireRow oDictIDout.Add key, wsZ.Rows.Count End If Next key 'Alle nicht enthaltenen IDs der neuen Tabelle werden übertragen. For Each key In oDictIDneu If Not oDictIDalt(key).exists And Not oDictIDout(key).exists Then wsA.Cells(oDictIDneu(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ.Rows.Count) _ , 1).End(xlUp).Offset(1, 0).EntireRow oDictIDout.Add key, wsZ.Rows.Count Else 'Die Werte werden 1x unabhängig von Verschiebungen in den Zeilen abgeglichen. For iii = 2 To 15 If wsN.Cells(oDictIDneu(key), iii).Value wsA.Cells(oDictIDalt(key), 111). _ Value Then 'hier werden entsprechend deines bisherigen Makros beide entsprechungen übertrage. ggf. eine _ Zeile löschen. wsA.Cells(oDictIDalt(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ. _ Rows.Count), 1).End(xlUp).Offset(1, 0).EntireRow wsN.Cells(oDictIDneu(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ. _ Rows.Count), 1).End(xlUp).Offset(1, 0).EntireRow Exit For 'Nach einmaligem Kopieren wird nicht weitergesucht. _ -->Keine doppelten Zeilen! ;-) End If Next iii End If Next key End Sub Private Sub Weg(ws As Worksheet) ws.Range("A2:" & Cells(Rows.Count - 1, Columns.Count).Address).Clear End Sub

Hallo Bertl,
also so eine kleine Pausenaufgabe ohne Test ist halt doch nichts. :-)
Ich habe noch 4 Fehler behoben und getestet!

Sub Test()
Dim oDictIDneu As Object, oDictIDalt As Object, oDictIDout As Object
Dim maxRN As Integer
Dim maxRA As Integer
Dim wsN As Worksheet
Dim wsA As Worksheet
Dim wsZ As Worksheet
Dim i, iii As Long
Dim key
Set oDictIDneu = CreateObject("Scripting.dictionary")
Set oDictIDalt = CreateObject("Scripting.dictionary")
Set oDictIDout = CreateObject("Scripting.dictionary")
oDictIDout.RemoveAll
oDictIDalt.RemoveAll
oDictIDneu.RemoveAll
Set wsN = ThisWorkbook.Worksheets("Input_neu")
Set wsA = ThisWorkbook.Worksheets("Input_alt")
Set wsZ = ThisWorkbook.Worksheets("Output")
maxRN = wsN.Cells(wsN.Rows.Count, 1).End(xlUp).Row
maxRA = wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row
Call Weg(wsZ)
For i = 2 To maxRN
If Not oDictIDneu.exists(wsN.Cells(i, 1).Value) Then
oDictIDneu.Add wsN.Cells(i, 1).Value, i                   'Hier wird die ID mit der  _
_
Zeilennummer eingetragen.
Else
x = MsgBox(wsN.Cells(i, 1) & "ist doppelt in der Tabelle Neu enthalten", vbOKOnly, " _
Doppelte Werte")
End If
Next i
For i = 2 To maxRA
If Not oDictIDalt.exists(wsA.Cells(i, 1).Value) Then
oDictIDalt.Add wsA.Cells(i, 1).Value, i                   'Hier wird die ID mit der  _
_
Zeilennummer eingetragen.
Else
x = MsgBox(wsN.Cells(i, 1) & "ist doppelt in der Tabelle NEu enthalten", vbOKOnly, " _
Doppelte Werte")
End If
Next i
'Alle nicht enthaltenen IDs der alten Tabelle werden übertragen.
For Each key In oDictIDalt
If Not oDictIDneu.exists(key) And Not oDictIDout.exists(key) Then
wsA.Cells(oDictIDalt(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ.Rows.Count) _
, 1).End(xlUp).Offset(1, 0).EntireRow
oDictIDout.Add key, wsZ.Rows.Count
End If
Next key
'Alle nicht enthaltenen IDs der neuen Tabelle werden übertragen.
For Each key In oDictIDneu
If Not oDictIDalt.exists(key) And Not oDictIDout.exists(key) Then
wsN.Cells(oDictIDneu(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ.Rows.Count) _
, 1).End(xlUp).Offset(1, 0).EntireRow
oDictIDout.Add key, wsZ.Rows.Count
ElseIf Not oDictIDout.exists(key) Then
'Die Werte werden 1x unabhängig von Verschiebungen in den Zeilen abgeglichen.
For iii = 2 To 15
If wsN.Cells(oDictIDneu(key), iii).Value  wsA.Cells(oDictIDalt(key), iii). _
Value Then
'hier werden entsprechend deines bisherigen Makros beide entsprechungen übertrage. ggf. eine  _
Zeile löschen.
wsA.Cells(oDictIDalt(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ. _
Rows.Count), 1).End(xlUp).Offset(1, 0).EntireRow
wsN.Cells(oDictIDneu(key), 1).EntireRow.Copy Destination:=wsZ.Cells((wsZ. _
Rows.Count), 1).End(xlUp).Offset(1, 0).EntireRow
Exit For                'Nach einmaligem Kopieren wird nicht weitergesucht.  _
-->Keine doppelten Zeilen! ;-)
End If
Next iii
End If
Next key
End Sub
Private Sub Weg(ws As Worksheet)
ws.Range("A2:" & Cells(Rows.Count - 1, Columns.Count).Address).Clear
End Sub

Die Fehlermeldung deines letzten Beitrags war leider klar ersichtlich! Ich habe die Abfrage ja oben im Makro schon richtig verwendet.

statt:
If Not oDictIDneu(key).exists And Not oDictIDout(key).exists Then
ist richtiger:
If Not oDictIDneu.exists (key) And Not oDictIDout.exists(key) Then

Wenn ich dann noch das Value und nicht die ganze Zelle in das Dictionary aufnehme, geht dass noch besser.

statt:
oDictIDalt.Add wsA.Cells(i, 1), i
besser:
oDictIDalt.Add wsA.Cells(i, 1).value, i

Dann habe ich noch einen Elseif eingefügt,
damit wird es noch einmal schneller.

ElseIf Not oDictIDout.exists(key) Then

Zum Schluss hatte ich noch wsa mit wsn verwechselt.
Inwiefern könnte das ein Problem sein? Das Skript definiert bei jedem Durchlauf den zu betrachtenden Bereich eh wieder neu soweit ich das richtig verstehe?

Das ist richtig. Wie erkennt diese Funktion jedoch, dass die einmalige HauptID in Zeile 15 ist, wenn du (vorausgesetzt deine HauptID ist in Spalte A) die Spalte A nicht nach der ID durchsuchst?
Mein Vorschlag arbeite mit den Dictionaries genau diese HauptID ab. (Sollte diese in einer anderen Spalte als A sein, musst du bei diesen Befehlen

oDictIDalt.Add wsA.Cells(i, 1).Value, i

die 1 ändern.
Wurde eine Zeile einmal kopiert, werden die Einzelspalten gar nicht mehr durchsucht.
--> Nicht alle Zeilen einer Spalte nach dem Wert durchsuchen, sondern "nur" die Spalten einer definierten Zeile, die noch nicht kopiert wurde durchsuchen.
Es war jetzt etwas ausführlich, aber ich hoffe du hast mit diesem Makro viel Spaß.
Gruß
Jürgen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Vergleich 2 Tabellen Makro

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread