Anzeige
Archiv - Navigation
1160to1164
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Identische und unterschiedliche Datensätze suchen

Identische und unterschiedliche Datensätze suchen
Stefan
Hallo,
ich beziehe mich auf Archiv-IDX 1161316 vom 2010-06-10 20:21:10. Herzlichen Dank an den Sepp. Der Code funktioniert super. Aber eine Frage:
Der jetzige Quellcode leistet folgendes: Zwei Dateien (z. Bsp. x, y, jeweils Tabelle1) werden nach identischen Einträgen in der jeweiligen Spalte A verglichen und in einem separaten Tabellenblatt (in der Datei in welcher der Code steht) wird ausgegeben welche Einträge nur in x, welche nur in y und welche in beiden Dateien vorkommen.
Der Quellcode (den mir Sepp zur Verfügung gestellt hat) funktioniert super. Nun wäre es prima, wenn man diesen Quellcode so erweitern könnte, daß nicht nur auf identische Einträge in Spalte A sondern auf ganze identische Datensätze geprüft werden kann. Die Struktur der Tabellen ist gleich. In der ersten Zeile stehen die Überschriften. Und um die Sache noch komplizierter zu machen (nur wenn es nicht soviel Arbeit macht): Können der Ausgabe noch die Zeilennummern in der die jeweiligen Datensätze stehen mit angegeben weren?
Hier nochmal der Quellcode vom Sepp:
Sub compareSheets()
Dim objWB As Workbook
Dim vntSrc1 As Variant, vntSrc2 As Variant
Dim vntInBoth() As Variant, vntInFirstOnly() As Variant, vntInSecondOnly() As Variant
Dim lngIndex As Long, lngCBoth As Long, lngCFirst As Long, lngCSecond As Long
Dim vntRet As Variant, blnWasOpen As Boolean
Dim strFile1 As String, strFile2 As String
strFile1 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Bitte erste Datei wählen")
If strFile1 = CStr(False) Then Exit Sub
strFile2 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Bitte zweite Datei wählen")
If strFile2 = CStr(False) Then Exit Sub
On Error GoTo Errexit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWB In Workbooks
If objWB.FullName = strFile1 Then
blnWasOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile1)
With objWB.Sheets("Tabelle1")
vntSrc1 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
If Not blnWasOpen Then objWB.Close False
Set objWB = Nothing
blnWasOpen = False
For Each objWB In Workbooks
If objWB.FullName = strFile2 Then
blnWasOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile2)
With objWB.Sheets("Tabelle1")
vntSrc2 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
If Not blnWasOpen Then objWB.Close False
Redim vntInBoth(0)
vntInBoth(0) = "In beiden Dateien"
lngCBoth = 1
Redim vntInFirstOnly(0)
vntInFirstOnly(0) = "Nur in Datei " & strFile1
lngCFirst = 1
Redim vntInSecondOnly(0)
vntInSecondOnly(0) = "Nur in Datei " & strFile2
lngCSecond = 1
For lngIndex = 1 To UBound(vntSrc1, 1)
vntRet = Application.Match(vntSrc1(lngIndex, 1), vntSrc2, 0)
If IsNumeric(vntRet) Then
Redim Preserve vntInBoth(lngCBoth)
vntInBoth(lngCBoth) = vntSrc1(lngIndex, 1)
lngCBoth = lngCBoth + 1
Else
Redim Preserve vntInFirstOnly(lngCFirst)
vntInFirstOnly(lngCFirst) = vntSrc1(lngIndex, 1)
lngCFirst = lngCFirst + 1
End If
Next
For lngIndex = 1 To UBound(vntSrc2, 1)
vntRet = Application.Match(vntSrc2(lngIndex, 1), vntSrc1, 0)
If Not IsNumeric(vntRet) Then
Redim Preserve vntInSecondOnly(lngCSecond)
vntInSecondOnly(lngCSecond) = vntSrc2(lngIndex, 1)
lngCSecond = lngCSecond + 1
End If
Next
ThisWorkbook.Worksheets.Add after:=ActiveSheet
With ActiveSheet
.Name = "Vergleich_" & Format(Now, "yyyymmdd-hhMMss")
.Range("A1").Resize(UBound(vntInBoth) + 1, 1) = Application.Transpose(vntInBoth)
.Range("B1").Resize(UBound(vntInFirstOnly) + 1, 1) = Application.Transpose(vntInFirstOnly)
.Range("C1").Resize(UBound(vntInSecondOnly) + 1, 1) = Application.Transpose(vntInSecondOnly) _
.Rows(1).Font.Bold = True
.Columns.AutoFit
End With
Errexit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objWB = Nothing
End Sub

Mit freundlichen Grüßen
Stefan

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Identische und unterschiedliche Datensätze suchen
16.06.2010 15:03:52
fcs
Hallo Stefan,
hier ein Ansatz. Er funktioniert aber nur korrekt, wenn die Einträge in Spalte A jeweils nur einmal vorkommen. Ansonsten müsste der Vergleichsalgorithmus komplett anders aufgebaut werden.
Gruß
Franz
Sub compareSheets()
Dim objWB As Workbook
Dim vntSrc1 As Variant, vntSrc2 As Variant
Dim vntInBoth() As Variant, vntInFirstOnly() As Variant, vntInSecondOnly() As Variant
Dim vntIdentisch() As Variant, vntInFirst() As Variant, vntInSecond() As Variant
Dim vntZeileFirst() As Variant, vntZeileSecond() As Variant
Dim vntDataFirst As Variant, vntDataSecond As Variant
Dim bolIdentisch As Boolean, Spalte As Long
Dim lngIndex As Long, lngCBoth As Long, lngCFirst As Long, lngCSecond As Long
Dim vntRet As Variant, blnWasOpen As Boolean
Dim strFile1 As String, strFile2 As String
strFile1 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Bitte erste Datei wählen")
If strFile1 = CStr(False) Then Exit Sub
strFile2 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Bitte zweite Datei wählen")
If strFile2 = CStr(False) Then Exit Sub
On Error GoTo Errexit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWB In Workbooks
If objWB.FullName = strFile1 Then
blnWasOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile1)
With objWB.Sheets("Tabelle1")
vntSrc1 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
vntDataFirst = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
If Not blnWasOpen Then objWB.Close False
Set objWB = Nothing
blnWasOpen = False
For Each objWB In Workbooks
If objWB.FullName = strFile2 Then
blnWasOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile2)
With objWB.Sheets("Tabelle1")
vntSrc2 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
vntDataSecond = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
If Not blnWasOpen Then objWB.Close False
ReDim vntInBoth(0)
vntInBoth(0) = "In beiden Dateien"
lngCBoth = 1
ReDim vntIdentisch(0)
vntIdentisch(0) = "Identisch"
ReDim vntInFirst(0)
vntInFirst(0) = "Zeile " & strFile1
ReDim vntInSecond(0)
vntInSecond(0) = "Zeile " & strFile2
ReDim vntInFirstOnly(0)
vntInFirstOnly(0) = "Nur in Datei " & strFile1
lngCFirst = 1
ReDim vntZeileFirst(0)
vntZeileFirst(0) = "Zeile"
ReDim vntInSecondOnly(0)
vntInSecondOnly(0) = "Nur in Datei " & strFile2
lngCSecond = 1
ReDim vntZeileSecond(0)
vntZeileSecond(0) = "Zeile"
For lngIndex = 1 To UBound(vntSrc1, 1)
vntRet = Application.Match(vntSrc1(lngIndex, 1), vntSrc2, 0)
If IsNumeric(vntRet) Then
ReDim Preserve vntInBoth(lngCBoth)
vntInBoth(lngCBoth) = vntSrc1(lngIndex, 1)
bolIdentisch = True
'Vergleich der Werte in den Spalten der Zeilen
For Spalte = LBound(vntDataFirst, 2) To UBound(vntDataFirst, 2)
If vntDataFirst(lngIndex, Spalte)  vntDataSecond(vntRet, Spalte) Then
bolIdentisch = False
Exit For
End If
Next
ReDim Preserve vntIdentisch(lngCBoth)
vntIdentisch(lngCBoth) = bolIdentisch
ReDim Preserve vntInFirst(lngCBoth)
vntInFirst(lngCBoth) = lngIndex + 1
ReDim Preserve vntInSecond(lngCBoth)
vntInSecond(lngCBoth) = vntRet + 1
lngCBoth = lngCBoth + 1
Else
ReDim Preserve vntInFirstOnly(lngCFirst)
vntInFirstOnly(lngCFirst) = vntSrc1(lngIndex, 1)
ReDim Preserve vntZeileFirst(lngCFirst)
vntZeileFirst(lngCFirst) = lngIndex + 1
lngCFirst = lngCFirst + 1
End If
Next
For lngIndex = 1 To UBound(vntSrc2, 1)
vntRet = Application.Match(vntSrc2(lngIndex, 1), vntSrc1, 0)
If Not IsNumeric(vntRet) Then
ReDim Preserve vntInSecondOnly(lngCSecond)
vntInSecondOnly(lngCSecond) = vntSrc2(lngIndex, 1)
ReDim Preserve vntZeileSecond(lngCSecond)
vntZeileSecond(lngCSecond) = lngIndex + 1
lngCSecond = lngCSecond + 1
End If
Next
ThisWorkbook.Worksheets.Add after:=ActiveSheet
With ActiveSheet
.Name = "Vergleich_" & Format(Now, "yyyymmdd-hhMMss")
.Range("A1").Resize(UBound(vntInBoth) + 1, 1) = Application.Transpose(vntInBoth)
.Range("B1").Resize(UBound(vntIdentisch) + 1, 1) = Application.Transpose(vntIdentisch)
.Range("C1").Resize(UBound(vntInFirst) + 1, 1) = Application.Transpose(vntInFirst)
.Range("D1").Resize(UBound(vntInSecond) + 1, 1) = Application.Transpose(vntInSecond)
.Range("E1").Resize(UBound(vntInFirstOnly) + 1, 1) = Application.Transpose(vntInFirstOnly)
.Range("F1").Resize(UBound(vntZeileFirst) + 1, 1) = Application.Transpose(vntZeileFirst)
.Range("G1").Resize(UBound(vntInSecondOnly) + 1, 1) = Application.Transpose(vntInSecondOnly) _
.Range("H1").Resize(UBound(vntZeileSecond) + 1, 1) = Application.Transpose(vntZeileSecond)
.Rows(1).Font.Bold = True
.Columns.AutoFit
End With
Errexit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objWB = Nothing
End Sub

Anzeige
AW: Identische und unterschiedliche Datensätze suchen
16.06.2010 15:32:26
Stefan
Hallo Franz,
Herzlichen Dank, ich habe den Quellcode ausprobiert und er funktioniert hervorragend. Allerdings kann ich nicht ausschließen, daß Einträge in Spalte A einer Tabelle mehrfach vorkommen. Ich erhalte die Tabellen von Kollegen zum weiterbearbeiten. Wenn es aber ein zu großer Arbeitsaufwand ist den Suchalgorithmus zu ändern, dann werde ich im Vorfeld versuchen Mehrfacheinträg zu eliminieren.
Eine andere Funktionalität wäre für mich sehr praktisch: Ist es möglich eine Abfrage einzubauen, mit der ich abfragen kann welche Spalte der unterschiedlichen Tabellen verglichen werden soll? (im Moment ist es statisch Spalte A). Die Struktur der Tabellen ist gleich.
Und noch eine Frage: Ich arbeite mit Excel 2007 erst seit kurzem im Büro. Bei XP, das ich vorher nutzte konnte ich eine benutzerdefinierte Symbolleiste einfügen, was sehr praktische war. Geht das bei Excel 2007 auch?
Viele Grüße
Stefan
Anzeige
AW: Identische und unterschiedliche Datensätze suchen
16.06.2010 17:05:05
fcs
Hallo Stefan,
die Auswahl der zu vergleichenden Spalte ist in dem in der Textdatei hochgeladenem Code enthalten.
https://www.herber.de/bbs/user/70100.txt
Die Programmierung des Abgleichs bei mehrfach in einer Spalte vorkommenden Werten in der Vergleichsspalte der 2. Datei ist mir momentan etwas zu aufwendig. Die Routine vergleicht immer mit der 1. Trefferzeile in der 2. Datei.
Persönliche Symbolleisten (Ribbons) sind in Excel 2007 anders/aufwendiger zu programmieren. In gewissem Umfang kannst du eigene Makros über Schaltflächen in der Schnellzugriffsleiste starten.
Gruß
Franz
Anzeige
AW: Identische und unterschiedliche Datensätze suchen
16.06.2010 17:10:37
Stefan
Hallo Franz,
Vielen Dank für die Hilfe. Der Code funktioniert hervorragend.
Viele Grüße
Stefan

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige