2 Listen vergleichen

Dauth · 2016-07-18T11:44:41+00:00

Hallo alle zusammen! Ich muss für meine Arbeit 2 Listen miteinander vergleichen. Dafür bräuchte ich ein Makro für folgendes Problem: Zum einen soll die Spalte L der Tabelle 2 (neue Daten) mit der Spalte L der Tabelle 1 (alte Daten) verglichen werden. In dieser Spalte L sind Teilenummern. Wenn eine Teilnummer in dieser Spalte neu hinzugekommen ist in Tabelle 2 soll die komplette Zeile der Tabelle 2 mit der neuen Teilenummer in Tabelle 3 kopiert werden. Tabelle 3 soll zu beginn des Kopiervorgangs immer gelöscht werden Zum anderen soll aber von der anderen Seite geschaut werden ob in Tabelle 2 (neue Daten) Teilenummern weggefallen sind. D.h. Tabelle 1 (alte Daten) Spalte L soll mit Tabelle 2 (neue Daten) Spalte L verglichen werden. Wenn in Tabelle 1 in Spalte L eine Teilenummer ist die in Tabelle 2 (neue Stand) nicht mehr vorhanden ist soll auch diese ganze Zeile in Tabelle 4 kopiert werden. Diese Tabelle soll vorher aber nicht gelöscht werden, sondern die weggefallenen Teilenummer sollen zur alten Liste ergänzt werden die ggf. vom vorherigen ausführen des Makros in Tabelle 4 stehen. Ich hoffe ihr könnt mir weiterhelfen. Vielen Dank im Voraus

Hallo Dauth,
...kriegen wir noch hin ;-):

Sub ListenVergleichUndKopie()
Dim Wb As Workbook
Dim WsAlt As Worksheet
Dim WsNeu As Worksheet
Dim TeileAlt As Worksheet
Dim TeileNeu As Worksheet
Dim arrAlt, arrNeu
Dim i As Long, z As Long, j As Long
Dim s
Dim clc
Dim t
With Application
clc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set Wb = ThisWorkbook
With Wb
Set WsAlt = .Worksheets("Alte_Daten")
Set WsNeu = .Worksheets("Neue_Daten")
Set TeileAlt = .Worksheets("Alte_Teile")
Set TeileNeu = .Worksheets("Neue_Teile")
End With
With WsAlt
arrAlt = Application.Transpose(.Range("K2:K" & _
.Cells(.Rows.Count, 11).End(xlUp).Row))
End With
With WsNeu
arrNeu = Application.Transpose(.Range("K2:K" & _
.Cells(.Rows.Count, 11).End(xlUp).Row))
End With
With TeileNeu
.Cells.Clear
WsNeu.Range("A1:K1").Copy
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
On Error Resume Next
For i = LBound(arrNeu) To UBound(arrNeu)
s = Application.Match(arrNeu(i), arrAlt, 0)
If IsError(s) Then
Err.Clear
z = i + 1
WsNeu.Range(Cells(z, 1), Cells(z, 11)).Copy
With TeileNeu
j = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(j, 1).PasteSpecial xlPasteValues
.Cells(j, 1).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next i
For i = LBound(arrAlt) To UBound(arrAlt)
s = Application.Match(arrAlt(i), arrNeu, 0)
If IsError(s) Then
Err.Clear
z = i + 1
WsAlt.Range(Cells(z, 1), Cells(z, 11)).Copy
With TeileAlt
j = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(j, 1).PasteSpecial xlPasteValues
.Cells(j, 1).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
Next i
With Application
.Calculation = clc
.ScreenUpdating = True
End With
Set Wb = Nothing
Set WsAlt = Nothing
Set WsNeu = Nothing
Set TeileAlt = Nothing
Set TeileNeu = Nothing
Erase arrAlt
Erase arrNeu
End Sub

Wie immer: Testen in einer Kopie, nicht der Produktiv-Datei!
LG
Michael

Hallo Dauth!
Hab's nochmal "von Null" geschrieben, kann sein, dass ich in der Eile beim vorigen Code irgendwo schlampig war.
Bitte teste folgenden Code (wieder auf Basis Deiner Bsp-Mappe erstellt). Diesmal sollte alles wie gewünscht klappen:

Sub ListenAbgleichen()
'Wenn Teilenummer aus Neue_Daten nicht in Alte_Daten, dann diesen Datensatz
'in Neue_Teile kopieren
'Neue_Teile soll vor dem Vorgang geleert werden
'Wenn Teilenummer aus Alte_Daten nicht in Neue_Daten, dann diesen Datensatz
'in Alte_Teile kopieren (wird zuvor NICHT geleert)
Dim Wb As Workbook
Dim DatenNeu As Worksheet
Dim DatenAlt As Worksheet
Dim TeileNeu As Worksheet
Dim TeileAlt As Worksheet
Dim arrNeu, arrAlt
Dim i As Long, j As Long, s, z As Long
Dim clc
With Application
clc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set Wb = ThisWorkbook
With Wb
Set DatenNeu = .Worksheets("Neue_Daten")
Set DatenAlt = .Worksheets("Alte_Daten")
Set TeileNeu = .Worksheets("Neue_Teile")
Set TeileAlt = .Worksheets("Alte_Teile")
End With
With TeileNeu
.Cells(2, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 11).Clear
End With
With DatenNeu
arrNeu = Application.Transpose(.Range("K2:K" & .Cells(.Rows.Count, 11).End(xlUp).Row))
End With
With DatenAlt
arrAlt = Application.Transpose(.Range("K2:K" & .Cells(.Rows.Count, 11).End(xlUp).Row))
End With
For i = LBound(arrNeu) To UBound(arrNeu)
s = Application.Match(arrNeu(i), arrAlt, 0)
If IsError(s) Then
j = i + 1
With DatenNeu
.Range(.Cells(j, 1), .Cells(j, 11)).Copy
With TeileNeu
z = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(z, 1).PasteSpecial xlPasteValues
.Cells(z, 1).PasteSpecial xlPasteFormats
End With
End With
End If
Next i
For i = LBound(arrAlt) To UBound(arrAlt)
s = Application.Match(arrAlt(i), arrNeu, 0)
If IsError(s) Then
j = i + 1
With DatenAlt
.Range(.Cells(j, 1), .Cells(j, 11)).Copy
With TeileAlt
z = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(z, 1).PasteSpecial xlPasteValues
.Cells(z, 1).PasteSpecial xlPasteFormats
End With
End With
End If
Next i
MsgBox "Listen wurden abgeglichen!", vbInformation, "Fertig!"
With Application
.Calculation = clc
.ScreenUpdating = True
.CutCopyMode = False
End With
Set Wb = Nothing
Set DatenNeu = Nothing
Set DatenAlt = Nothing
Set TeileNeu = Nothing
Set TeileAlt = Nothing
Erase arrNeu
Erase arrAlt
End Sub

LG
Michael

Forumthread: 2 Listen vergleichen

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2 Listen vergleichen

Forumthread: 2 Listen vergleichen

24 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread