2 Arbeitsblätter vergleichen und kopieren

Forumthread: 2 Arbeitsblätter vergleichen und kopieren

16.08.2019 13:44:45

Marcel

Hallo liebes Forum,
ich stehe vor der Herausforderung 2 Arbeitsblätter zu vergleichen und zum einen die doppelten Werte und zum anderen die neu hinzugekommenen Werte in ein separates Arbeitsblatt zu kopieren.
Konkretes Problem:
Ich habe in dem Arbeitsblatt "Tabelle1" meine neuen Werte und in "Tabelle2" die alten Werte stehen (In der Zeile 1 sind Spaltenüberschriften vorhanden). Anhand von 2 eindeutigen Kriterien die zum einen in der Spalte I und der Spalte K stehen, sollen die beiden Arbeitsblätter miteinander verglichen werden und wenn die Werte übereinstimmen soll die ganze Zeile in "Tabelle3" kopiert werden. Falls kein oder nur ein Wert übereinstimmt, soll die komplette Zeile in "Tabelle4" kopiert werden.
Ich hoffe mir kann jemand bei diesem Problem weiterhelfen.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: 2 Arbeitsblätter vergleichen und kopieren

16.08.2019 14:33:06

Hajo_Zi

nur wenige schauen auf Deinen Rechner und sehen die Datei.
Ich möchte gerne den Fehler im Original sehen.
Ich baue keine Datei nach. Die Zeit hat schon jemand investiert.
Ein Nachbau sieht meist anders aus als das Original. Darum sollte das Original verlinkt werden.
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten anonymisieren bzw. pseudonymisieren.
Benutze hier im Forum die Funktion zum hochladen. Falls Du die nicht benutzen möchtest beachte, von unsicheren Servern wie z.B. www.file-upload.net lade ich keine Datei runter. (lt. Einschätzung meines Virenprogramms)

Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
Die Beiträge werden auch ignoriert, es erfolgt keine Antwort.

AW: 2 Arbeitsblätter vergleichen und kopieren

16.08.2019 15:27:30

Marcel

Hallo Hajo,
schon einmal vielen Dank für deine schnelle Antwort. Unter nachfolgendem Link kannst du die Excel-Datei aufrufen (bei dieser Datei handelt es sich um einen Ausschnitt. Unterschied zur Originaldatei sind nur die Anzahl der Zeilen ca. 100000):
https://www.herber.de/bbs/user/131460.xlsx

AW: 2 Arbeitsblätter vergleichen und kopieren

16.08.2019 15:51:16

Marcel

Ich habe bereits ein Makro gefunden und es soweit angepasst, dass meine Anforderungen fast erfüllt werden. Bei diesem Makro wird allerdings nur die Spalte I in den beiden Arbeitsblättern miteinander verglichen. Um Fehler beim vergleichen auszuschließen ist es notwendig, dass neben der Spalte I auch noch ein Abgleich mit der Spalte K erfolgt und erst wenn beide Spalten identisch sind, soll die Zeile in Tabelle3 geschrieben werden. Falls kein oder nur ein Wert richtig ist, soll die jeweilige Zeile in Tabelle4 geschrieben werden. Weiterhin müssten die beiden nachfolgenden Makros für die bessere Übersicht zusammengefügt werden.

Sub Doppelte_Kopieren()
Dim lngRow As Long
Dim lngLast As Long
Dim findRow As Range
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 9).End(xlUp).Row
Worksheets("Tabelle3").UsedRange.ClearContents
Application.ScreenUpdating = False
With Worksheets("Tabelle1") 'Neudaten
For lngRow = 1 To lngLast
If Not IsError(Application.Match(.Cells(lngRow, 9), Worksheets("Tabelle2").Columns(9), 0)) Then
If findRow Is Nothing Then
Set findRow = Worksheets("Tabelle1").Rows(lngRow)
Else
Set findRow = Union(findRow, Worksheets("Tabelle1").Rows(lngRow))
End If
End If
Next lngRow
findRow.EntireRow.Copy Worksheets("Tabelle3").Cells(1, 1)
End With
Application.ScreenUpdating = True
End Sub

Sub Neue_Kopieren()
Dim lngRow As Long
Dim lngLast As Long
Dim findRow As Range
lngLast = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Tabelle4").UsedRange.ClearContents
Application.ScreenUpdating = False
With Worksheets("Tabelle1") 'Neudaten
For lngRow = 1 To lngLast
If IsError(Application.Match(.Cells(lngRow, 9), Worksheets("Tabelle2").Columns(9), 0)) Then
If findRow Is Nothing Then
Set findRow = Worksheets("Tabelle1").Rows(lngRow)
Else
Set findRow = Union(findRow, Worksheets("Tabelle1").Rows(lngRow))
End If
End If
Next lngRow
findRow.EntireRow.Copy Worksheets("Tabelle4").Cells(1, 1)
End With
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

2 Arbeitsblätter vergleichen und kopieren

Forumthread: 2 Arbeitsblätter vergleichen und kopieren

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2 Arbeitsblätter vergleichen und kopieren

Forumthread: 2 Arbeitsblätter vergleichen und kopieren

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread