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