' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub compare()
Dim objWB As Workbook, objNewSheet As Worksheet
Dim strFile As String, strTabA As String, strTabB As String
Dim vntA As Variant, vntB As Variant, vntOut As Variant
Dim lngFirstData As Long, lngI As Long, lngBoth As Long, lngA As Long, lngB As Long
Dim vntRet As Variant
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
lngFirstData = 2 'Erste Datenzeile
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "E:\Forum"
.Title = "Datei auswählen"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then strFile = .SelectedItems(1)
End With
If Len(strFile) Then
strTabA = "Tabelle1" 'Name der Tabelle in dieser Datei (Datei A)
strTabB = "Tabelle1" 'Name der Tabelle in Datei B
Set objWB = Workbooks.Open(strFile)
With objWB.Sheets(strTabB)
vntB = .Range(.Cells(lngFirstData, 3), .Cells(Application.Max(lngFirstData, .Cells(.Rows.Count, _
3).End(xlUp).Row), 3))
End With
objWB.Close False
With ThisWorkbook.Sheets(strTabA)
vntA = .Range(.Cells(lngFirstData, 2), .Cells(Application.Max(lngFirstData, .Cells(.Rows.Count, _
2).End(xlUp).Row), 2))
End With
Redim vntOut(1 To UBound(vntA, 1) + UBound(vntB, 1), 1 To 3)
For lngI = 1 To UBound(vntA, 1)
vntRet = Application.Match(vntA(lngI, 1), vntB, 0)
If IsNumeric(vntRet) Then
lngBoth = lngBoth + 1
vntOut(lngBoth, 1) = vntA(lngI, 1)
vntA(lngI, 1) = ""
vntB(vntRet, 1) = ""
Else
lngA = lngA + 1
vntOut(lngA, 2) = vntA(lngI, 1)
vntA(lngI, 1) = ""
End If
Next
For lngI = 1 To UBound(vntB, 1)
If vntB(lngI, 1) <> "" Then
vntRet = Application.Match(vntB(lngI, 1), vntA, 0)
If IsNumeric(vntRet) Then
lngBoth = lngBoth + 1
vntOut(lngBoth, 1) = vntB(lngI, 1)
vntB(lngI, 1) = ""
vntA(vntRet, 1) = ""
Else
lngB = lngB + 1
vntOut(lngB, 3) = vntB(lngI, 1)
vntB(lngI, 1) = ""
End If
End If
Next
Set objNewSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
With objNewSheet
.Name = "Compare_" & Format(Now, "yyyyMMdd-hhmmss")
.Range("A1") = "In A & B"
.Range("B1") = "Nur in A"
.Range("C1") = "Nur in B"
.Range("A2").Resize(UBound(vntOut, 1), 3) = vntOut
End With
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'compare'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - compare"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
End With
Set objWB = Nothing
Set objNewSheet = Nothing
End Sub