Option Explicit
Dim PfadName1 As Variant
Dim PfadName2 As Variant
Dim sDateiName1 As String
Dim sDateiName2 As String
Dim bDateiNum1 As Byte
Dim bDateiNum2 As Byte
Dim wb1 As Workbook
Dim wb2 As Workbook
Private Sub CommandButton1_Click()
Call GetOpen_FileName
Call Vergleich_Faerbung
End Sub
Private Sub GetOpen_FileName()
Dim i As Long
Dim n As Long
Dim x As Long
Dim intWS As Byte
Dim lName1 As Long
Dim lName2 As Long
MsgBox "Wählen Sie die beiden Exceltabellen die Verglichen werden sollen.", vbQuestion & vbOKOnly, "Info"
ChDrive "S"
ChDir "S:\Projekte"
PfadName1 = Application.GetOpenFilename("Excel-Dateien (*.xl??), *.xl??", Title:="Bitte Exceldatei auswählen", MultiSelect:=False)
If Not PfadName1 = False Then
Workbooks.Open PfadName1
PfadName1 = Mid$(PfadName1, InStrRev(PfadName1, "\") + 1)
x = (InStrRev(CStr(PfadName1), ".") - 1)
lName1 = Len(PfadName1) - (Len(PfadName1) - x)
sDateiName1 = Left(PfadName1, lName1)
Else
Exit Sub
End If
Workbooks(sDateiName1).Worksheets(1).Range("A:A").Select
Selection.Copy
Windows("Vergleich_Excel.xlsm").Activate
Columns("A:A").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Application.CutCopyMode = False
PfadName2 = Application.GetOpenFilename("Excel-Dateien (*.xl??), *.xl??", Title:="Bitte die Vergleichsdatei auswählen", MultiSelect:=False)
If Not PfadName2 = False Then
Workbooks.Open PfadName2
PfadName2 = Mid$(PfadName2, InStrRev(PfadName2, "\") + 1)
i = (InStrRev(CStr(PfadName2), ".") - 1)
lName2 = Len(PfadName2) - (Len(PfadName2) - i)
sDateiName2 = Left(PfadName2, lName2)
Else
Exit Sub
End If
Workbooks(sDateiName2).Worksheets(1).Range("A:A").Select
Selection.Copy
Windows("Vergleich_Excel.xlsm").Activate
Columns("B:B").Select
ActiveSheet.Paste
Columns("B:B").EntireColumn.AutoFit
Application.CutCopyMode = False
If Workbooks(sDateiName1).Worksheets.Count <> Workbooks(sDateiName2).Worksheets.Count Then
MsgBox "Die Anzahl der Tabellenblätter ist unterschiedlich!"
End If
For intWS = 1 To Workbooks(sDateiName1).Worksheets.Count
If Workbooks(sDateiName1).Worksheets(intWS).UsedRange.Cells.Count <> Workbooks(sDateiName2).Worksheets(intWS).UsedRange.Cells.Count Then
MsgBox "Die Anzahl der benutzen Zellen in Blatt " & intWS & " " & "ist unterschiedlich!"
End If
Next intWS
End Sub
Sub Vergleich_Faerbung()
Dim i As Long
Dim x As Long
Dim k As Long
Dim n As Long
Dim objDic1 As Object
Dim objDic2 As Object
Dim strCount1 As String
Dim strCount2 As String
Set objDic1 = CreateObject("scripting.dictionary")
Set objDic2 = CreateObject("scripting.dictionary")
strCount1 = Cells(Rows.Count, 1).End(xlUp).Row
strCount2 = Cells(Rows.Count, 2).End(xlUp).Row
If PfadName1 Or PfadName2 = False Then
Exit Sub
Else
Workbooks(sDateiName1).Close SaveChanges:=False
Workbooks(sDateiName2).Close SaveChanges:=False
For i = 1 To strCount1
If Not objDic1.exists(Cells(i, 1).Value) Then
objDic1.Add Cells(i, 1).Value, i
End If
Next
For x = 1 To strCount2
If Not objDic2.exists(Cells(x, 2).Value) Then
objDic2.Add Cells(x, 2).Value, x
End If
Next
For k = 1 To strCount2
If objDic1.exists(ActiveSheet.Cells(k, 2).Value) Then
Cells(k, 2).Interior.ColorIndex = 4
Else
Cells(i, 2).Interior.ColorIndex = 3
End If
Next
For n = 1 To strCount1
If objDic2.exists(ActiveSheet.Cells(n, 1).Value) Then
Cells(n, 1).Interior.ColorIndex = 4
Else
Cells(n, 1).Interior.ColorIndex = 3
End If
Next
End If
End Sub