AW: Vergleich 2 Tabellen Makro
21.07.2016 12:35:07
Jürgen
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