2 Arbeitsblätter vergleichen und kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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.

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

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2 Arbeitsblätter vergleichen und kopieren

3 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)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread