AW: Identische und unterschiedliche Einträge suchen
10.06.2010 23:43:01
Josef
Hallo Stefan,
die Tabelle wird in der Datei die den Code enthält angelegt.
Füge den Code in ein allgemeines Modul ein.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
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
Gruß Sepp