Office: Tabellen per Makro vergleichen

Guten Abend zusammen!

Ich habe eine Excel-Datei mit 3 Tabellenblättern:
- Zusammenzug
- Zusammenzug_alt
- Mutationen

Im Tabellenblatt "Zusammenzug" werden täglich neue Artikel eingelesen, welche mit den Artikeln im Tabellenblatt "Zusammenzug_alt" verglichen werden müssen.

Nun möchte ich per Makro folgende Aktion auslösen: ich möchte alle Abweichungen zwischen den beiden Listen in das Tabellenblatt "Mutationen" schreiben lassen.

Beispiel: Auf dem Tabellenblatt "Zusammenzug" kommt der Artikel "Brot" neu dazu. Dieser Artikel ist auf der Liste "Zusammenzug_alt) natürlich nicht vorhanden. Nun müssten alle Artikel-Informationen jener Zeile (A bis F) in das Tabellenblatt "Mutationen" geschrieben werden. In der Zelle "G" müsste dann "Neu" stehen.

Umgekehrt kann auch passieren, dass ein Artikel auf dem Tabellenblatt "Zusammenzug" gelöscht wird (im Beispiel ist es der Artikel "Bier"). Dieser ist dann auf dem Tabellenblatt "Zusammenzug_alt) natürlich noch vorhanden. Nun müsste auch diese Zeile ins Tabellenblatt "Mutationen" übernommen werden; dieses Mal jedoch mit dem Hinweis "Gelöscht" in Zelle "G".

Normalerweise müssen so gegen 10'000 Artikel verglichen werden. Darum bin ich auf der Suche nach dem richtigen Makro-Code.

Kann mir Jemand von Euch in dieser für mich sehr wichtigen Angelegenheit helfen? Zur besseren Verständigung habe ich noch eine Beispiel-Datei eingefügt.

Ich danke vielmals für Eure Hilfe! Beste Grüsse, Matthias

:)

 

Hallo Matthias,

probier Mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub mutationen()
Dim vnt1 As Variant, vnt2 As Variant, vntMark() As Variant
Dim rng As Range
Dim lngIndex As Long, lngC As Long
Sheets("Mutationen").Range("A2:G" & Rows.Count).ClearContents
With Sheets("Zusammenzug")
vnt1 = .Range("B2:B" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
End With
With Sheets("Zusammenzug_alt")
vnt2 = .Range("B2:B" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
End With
With Sheets("Zusammenzug")
For lngIndex = 1 To UBound(vnt1, 1)
If IsError(Application.Match(vnt1(lngIndex, 1), vnt2, 0)) Then
Redim Preserve vntMark(lngC)
vntMark(lngC) = "Neu"
lngC = lngC + 1
If rng Is Nothing Then
Set rng = .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6))
Else
Set rng = Union(rng, .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6)))
End If
End If
Next
If Not rng Is Nothing Then
rng.Copy Sheets("Mutationen").Range("A2")
Sheets("Mutationen").Range("G2").Resize(UBound(vntMark) + 1, 1) = _
Application.Transpose(vntMark)
End If
End With
Set rng = Nothing
Erase vntMark
lngC = 0
With Sheets("Zusammenzug_alt")
For lngIndex = 1 To UBound(vnt2, 1)
If IsError(Application.Match(vnt2(lngIndex, 1), vnt1, 0)) Then
Redim Preserve vntMark(lngC)
vntMark(lngC) = "Gelöscht"
lngC = lngC + 1
If rng Is Nothing Then
Set rng = .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6))
Else
Set rng = Union(rng, .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6)))
End If
End If
Next
If Not rng Is Nothing Then
rng.Copy Sheets("Mutationen").Range("A1").End(xlDown).Offset(1, 0)
Sheets("Mutationen").Range("G1").End(xlDown).Offset(1, 0).Resize(UBound(vntMark) + 1, 1) = _
Application.Transpose(vntMark)
End If
End With
Set rng = Nothing
End Sub





« Gruß Sepp »

 

Hallo Sepp!

Vielen, herzlichen Dank für deine Hilfe! Du bist einfach der absolute Makro-König hier auf diesem Forum! :-)

Eine Frage noch; wie kann ich folgendes Makro laufen lassen, ohne dass dabei jeweils die im Code angewählten Tabellenblätter angezeigt werden:

Sheets("Zusammenzug").Select
Columns("A:F").Select
Selection.Copy
Sheets("Zusammenzug_neu").Select
Columns("A:F").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Mutationen").Select
Range("A1").Select


Gerne möchte ich das Makro "im Hintergrund" ausführen lassen.

Vielen Dank für deinen Ratschlag!

Schöne Grüsse, Matthias

 

Hallo Matthias,
Sheets("Zusammenzug").Columns("A:F").Copy
Sheets("Zusammenzug_neu").Columns("A:F").PasteSpecial Paste:=xlPasteValues

 

Hallo Hajo

Leider wird das Tabellenblatt bei deinem Code noch immer eingeblendet. Mache ich was falsch?

Viele Grüsse, Matthias

 

Hallo Matthias,

eigentlich sollte er es nicht. Schalte den Bildschirm aus.
Code:

 

Hallo Hajo

Vielen Dank; jetzt klappts! :-)

Nun habe ich noch ein kleines Problem beim Code von Sepp festgestellt. Und zwar funktioniert das Ganze wie geschrieben sehr gut. Das Problem ist nur, wenn kein neuer Artikel dazu gefügt wird, jedoch ein Artikel gelöscht wird, bleibt das Makro an folgender Stelle stehen:

rng.Copy Sheets("Mutationen").Range("A1").End(xlDown).Offset(1, 0)

Wenn aber beispielsweise ein Artikel dazu gefügt wird, funktiniert alles hervorragend. Auch wenn ein Artikel dazu gefügt und einer gelöscht wird, klappt alles. Einfach wenn "nur" Artikel gelöscht werden, läuft das Makro nicht bis zum Schluss durch.

Muss man den Code hier allenfalls anpassen?

Vielen, herzlichen Dank für die Hilfe!

Schöne Grüsse, Matthias

 

Hallo Matthias,

habe das Problem behoben.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub mutationen()
Dim vnt1 As Variant, vnt2 As Variant, vntMark() As Variant
Dim rng As Range
Dim lngIndex As Long, lngC As Long, lngNext As Long
Sheets("Mutationen").Range("A2:G" & Rows.Count).ClearContents
lngNext = 2
With Sheets("Zusammenzug")
vnt1 = .Range("B2:B" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
End With
With Sheets("Zusammenzug_alt")
vnt2 = .Range("B2:B" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
End With
With Sheets("Zusammenzug")
For lngIndex = 1 To UBound(vnt1, 1)
If IsError(Application.Match(vnt1(lngIndex, 1), vnt2, 0)) Then
Redim Preserve vntMark(lngC)
vntMark(lngC) = "Neu"
lngC = lngC + 1
If rng Is Nothing Then
Set rng = .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6))
Else
Set rng = Union(rng, .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6)))
End If
End If
Next
If Not rng Is Nothing Then
rng.Copy Sheets("Mutationen").Cells(lngNext, 1)
Sheets("Mutationen").Cells(lngNext, 7).Resize(UBound(vntMark) + 1, 1) = _
Application.Transpose(vntMark)
End If
End With
Set rng = Nothing
Erase vntMark
lngC = 0
With Sheets("Mutationen")
lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
End With
With Sheets("Zusammenzug_alt")
For lngIndex = 1 To UBound(vnt2, 1)
If IsError(Application.Match(vnt2(lngIndex, 1), vnt1, 0)) Then
Redim Preserve vntMark(lngC)
vntMark(lngC) = "Gelöscht"
lngC = lngC + 1
If rng Is Nothing Then
Set rng = .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6))
Else
Set rng = Union(rng, .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 6)))
End If
End If
Next
If Not rng Is Nothing Then
rng.Copy Sheets("Mutationen").Cells(lngNext, 1)
Sheets("Mutationen").Cells(lngNext, 7).Resize(UBound(vntMark) + 1, 1) = _
Application.Transpose(vntMark)
End If
End With
Set rng = Nothing
End Sub





« Gruß Sepp »

 

Hallo Sepp

Nochmals ganz herzlichen Dank für deine Hilfe! Wirklich perfekt so!

Merci und lieber Gruss, Matthias

 

Hallo Matthias,

hier ist noch eine Variante und der Code ist ein wenig kürzer

Beispiel Mappe "Beispiel_v1_.xls"

Gruß Peter9

 

Hallo Forum,

ich habe ein ähnliches Problem wie hier schon beschrieben. Im Anhang habe ich eine Datei angehängt und bitte euch diese mal anzuschauen.

Im Reiter "neu" habe ich ein Beispiel beschrieben.

Es handelt sich um zwei Tabellen die miteinander abgeglichen werden sollen.
Das Resultat soll dann in eine dritte Tabelle geschrieben werden.

Ich kenne mich überhaupt nicht mit VBA aus und hoffe dass mir jemand ein Makro bastelt.

Grüße
Richard

 

Hallo Richard,

Der Dateiname sollte was mit dem Problem zu tun haben. Ich habe mir z.B. einen Ordner angelegt in dem ich alle Dateien aus dem Internet speichere. Bei Dateinamen wie Test., Mappe.., Beispiel wird eine vorhandene überschrieben.
Tabelle vergleichen

 

Hallo Hajo,

ohje, da muss ich erstmal das Richtige Makro herausfinden.*confused.gif*

Grüße
Richard

 

Hallo Forum Hallo Hajo,

Ich habe nun viel probiert mit diesen Makros.
Das Beste Makro für mich ist dieses:

Code:

So ist die Beschreibung:

- Makro: Tabellen_Vergleich03
- jeder Wert in Tabelle1 Spalte A wird mit jedem Wert in Tabelle2 Spalte B verglichen
- bei Übereinstimmung wird die gesamte Zeile aus Tabelle1 nach Tabelle3 kopiert
- Datensätze in Tabelle3 werden vor dem Kopieren nicht gelöscht, neue Datensätze werden hinzugefügt


Es müsste nur etwas geändert werden:

Jeder Wert in Tabelle1 Spalte D wird mit jedem Wert in Tabelle2 Spalte D verglichen und in Tabelle 3 übertragen.


Kannst Du dass abändern für mich??

Grüße
Richard

 

Hallo Richard,

ich habe jetzt mal die Beschreibung aus dem Beispiel kopiert.

Tabelle1

	E	F	G	H	I	J	K	L	M
9	'- Makro: Tabellen_Vergleich03
10		'- jeder Wert in Tabelle1 Spalte A wird mit jedem Wert in Tabelle2 Spalte B vergli chen
11		'- bei Übereinstimmung wird die gesamte Zeile aus Tabelle1 nach Tabelle3 kopie rt
12		'- Datensätze in Tabelle3 werden vor dem Kopieren nicht gelöscht, neue Datensätze  werden hinzugefügt

verbundene Zellen

F10:M10

F11:M11

F12:M12

Gruß Hajo