Datenabgleich mittels VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo M. Usalis,
folgendes Makro geht davon aus, das deine Vergleichsdaten in Spalte A stehen. Es geht auch davon aus, dass bei den Ausgangsdaten, wenn vorne oder hinten noch ein "XX" steht, kein Leerzeichen zwischen "XX" und dem eigentlichen Inhalt (entsprechend Datei "Vergleichsdaten") steht. Den Dateinamen der Ausgangsdaten mußt du noch anpassen. Das Makro übernimmt bei nicht gefundenen Daten diese (ohne "XX") in die Liste in Vergleichsdaten und markiert außerdem die Zelle in Ausgangsdaten farbig.


Sub Datenabgleich()
Dim rng As Range, wks As Worksheet
For Each wks In Workbooks("Ausgangsdaten.xls").Worksheets 'Dateinamen anpassen
For Each rng In wks.UsedRange
If IsEmpty(rng) = False Then
'Prüfung mit Vergleichsdaten ohne "XX"
If ThisWorkbook.Worksheets("Liste").Columns("A:A") _
.Find(what:=rng, lookat:=xlWhole) Is Nothing Then
'wenn nicht gefunden, in Datei "Vergleichsdaten.xls" kopieren ...
rng.Copy Destination:=ThisWorkbook.Worksheets("Liste") _
.Range("A65536").End(xlUp).Offset(1, 0)
'... und in Datei "Ausgangsdaten.xls" farbig markieren
rng.Interior.ColorIndex = 22
'Prüfung mit Vergleichsdaten mit "XX" vorne
ElseIf ThisWorkbook.Worksheets("Liste").Columns("A:A") _
.Find(what:=Right(rng, Len(rng) - 2), lookat:=xlWhole) Is Nothing Then
'wenn nicht gefunden, in Datei "Vergleichsdaten.xls" kopieren ...
Right(rng, Len(rng) - 2).Copy Destination:=ThisWorkbook.Worksheets("Liste") _
.Range("A65536").End(xlUp).Offset(1, 0)
'... und in Datei "Ausgangsdaten.xls" farbig markieren
rng.Interior.ColorIndex = 22
'Prüfung mit Vergleichsdaten mit "XX" hinten
ElseIf ThisWorkbook.Worksheets("Liste").Columns("A:A") _
.Find(what:=Left(rng, Len(rng) - 2), lookat:=xlWhole) Is Nothing Then
'wenn nicht gefunden, in Datei "Vergleichsdaten.xls" kopieren ...
Left(rng, Len(rng) - 2).Copy Destination:=ThisWorkbook.Worksheets("Liste") _
.Range("A65536").End(xlUp).Offset(1, 0)
'... und in Datei "Ausgangsdaten.xls" farbig markieren
rng.Interior.ColorIndex = 22
End If
End If
Next rng 'nächste Zelle
Next wks 'nächstes Tabellenblatt
End Sub

Gruß Ingolf

Sub Datenabgleich() Dim rng As Range, wks As Worksheet For Each wks In Workbooks("Ausgangsdaten.xls").Worksheets 'Dateinamen anpassen For Each rng In wks.UsedRange If IsEmpty(rng) = False Then With ThisWorkbook.Worksheets("Liste").Columns("A:A") If .Find(what:=rng, lookat:=xlWhole) Is Nothing And _ .Find(what:=Right(rng, Len(rng) - 2), lookat:=xlWhole) Is Nothing And _ .Find(what:=Left(rng, Len(rng) - 2), lookat:=xlWhole) Is Nothing Then If .Find(what:=rng, lookat:=xlWhole) Is Nothing Then rng.Copy Destination:=ThisWorkbook.Worksheets("Liste") _ .Range("A65536").End(xlUp).Offset(1, 0) End If If .Find(what:=Right(rng, Len(rng) - 2), lookat:=xlWhole) _ Is Nothing Then Right(rng, Len(rng) - 2).Copy _ Destination:=ThisWorkbook.Worksheets("Liste") _ .Range("A65536").End(xlUp).Offset(1, 0) End If If .Find(what:=Left(rng, Len(rng) - 2), lookat:=xlWhole) _ Is Nothing Then Left(rng, Len(rng) - 2).Copy _ Destination:=ThisWorkbook.Worksheets("Liste") _ .Range("A65536").End(xlUp).Offset(1, 0) End If rng.Interior.ColorIndex = 22 End If End If Next rng 'nächste Zelle Next wks 'nächstes Tabellenblatt End Sub

Sub Datenabgleich() Dim rng As Range, wks As Worksheet For Each wks In Workbooks("Ausgangsdaten.xls").Worksheets 'Dateinamen anpassen For Each rng In wks.UsedRange If IsEmpty(rng) = False Then With ThisWorkbook.Worksheets("Liste").Columns("A:A") If .Find(what:=rng, lookat:=xlWhole) Is Nothing And _ .Find(what:=Right(rng, Len(rng) - 2), lookat:=xlWhole) Is Nothing And _ .Find(what:=Left(rng, Len(rng) - 2), lookat:=xlWhole) Is Nothing Then If .Find(what:=rng, lookat:=xlWhole) Is Nothing Then rng.Copy Destination:=ThisWorkbook.Worksheets("Liste") _ .Range("A65536").End(xlUp).Offset(1, 0) End If If .Find(what:=Right(rng, Len(rng) - 2), lookat:=xlWhole) _ Is Nothing Then Right(rng, Len(rng) - 2).Copy _ Destination:=ThisWorkbook.Worksheets("Liste") _ .Range("A65536").End(xlUp).Offset(1, 0) End If If .Find(what:=Left(rng, Len(rng) - 2), lookat:=xlWhole) _ Is Nothing Then Left(rng, Len(rng) - 2).Copy _ Destination:=ThisWorkbook.Worksheets("Liste") _ .Range("A65536").End(xlUp).Offset(1, 0) End If rng.Interior.ColorIndex = 22 End With End If Next rng 'nächste Zelle Next wks 'nächstes Tabellenblatt End Sub

Hi M.Usalis,
Anbei habe ich mal eine Lösung zur farblichen Hervorhebung der Daten in den Vergleichsmappen.
Ausgangspunkt ist hierbei:
1.) Arbeismappen "Ausgang.xls" und "Vergleich.xls" sind geöffnet
2.) Makro wird über Schaltfläche "vergleichen" im Tabellenblatt "Liste" gestartet
3.) Es werden in allen Tabellenblättern der Mappe "Vergleich" die gefundenen Nr. farblich hervorgehoben
Diese Lösung ist aber nur für ein Teil Deines Problem. Für die Übertragung der Daten, die nicht farblich gekennzeichnet wurden soll ja eine Übernahme in das Tabellenblatt "Liste" erfolgen.
Dazu ist es notwendig, genau festzulegen, welche Nummern das sind!
Der Aufbau der Nummern muß als Suchschlüssel herangezogen werden. Sind die Nummern immer nach dem gleichem Prinzip aufgebaut.
z.B. 2 Buchstaben zu Beginn und dann 3 Ziffern: OP388
maximal 5 Stellen?
https://www.herber.de/bbs/user/23285.zip

Fritz

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread