Option
Explicit
Dim
sDateiName1
As
String
Dim
sDateiName2
As
String
Dim
bDateiNum1
As
Byte
Dim
bDateiNum2
As
Byte
Private
Sub
CommandButton1_Click()
Call
GetOpen_FileName
End
Sub
Private
Sub
GetOpen_FileName()
Dim
sPfadName1
As
Variant
Dim
sPfadName2
As
Variant
Dim
i
As
Integer
Dim
n
As
Long
Dim
x
As
Long
Dim
lName1
As
Long
Dim
lName2
As
Long
Dim
iWorkbook
As
Integer
Dim
wb1
As
Workbook
Dim
wb2
As
Workbook
MsgBox
"Wählen Sie die beiden Exceltabellen die Verglichen werden sollen."
, vbQuestion & vbOKOnly,
"Info"
ChDrive
"T"
ChDir
"T:\delme\Ruckes\Vergleich"
sPfadName1 = Application.GetOpenFilename(
"Excel-Dateien (*.xl??), *.xl??"
, Title:=
"Bitte Exceldatei auswählen"
)
If
Not
sPfadName1 =
False
Then
Workbooks.Open sPfadName1
sPfadName1 = Mid$(sPfadName1, InStrRev(sPfadName1, "\") + 1)
x = (InStrRev(
CStr
(sPfadName1),
"."
) - 1)
lName1 = Len(sPfadName1) - (Len(sPfadName1) - x)
sDateiName1 = Left(sPfadName1, lName1)
Else
Exit
Sub
End
If
sPfadName2 = Application.GetOpenFilename(
"Excel-Dateien (*.xl??), *.xl??"
, Title:=
"Bitte die Vergleichsdatei auswählen"
)
If
Not
sPfadName2 =
False
Then
Workbooks.Open sPfadName2
sPfadName2 = Mid$(sPfadName2, InStrRev(sPfadName2, "\") + 1)
i = (InStrRev(
CStr
(sPfadName2),
"."
) - 1)
lName2 = Len(sPfadName2) - (Len(sPfadName2) - i)
sDateiName2 = Left(sPfadName2, lName2)
Else
Exit
Sub
End
If
Set
wb1 = Workbooks(sDateiName1)
Set
wb2 = Workbooks(sDateiName2)
For
iWorkbook = 1
To
Workbooks.Count
If
Workbooks(iWorkbook).Name = wb1.Name
Then
bDateiNum1 = iWorkbook
End
If
If
Workbooks(iWorkbook).Name = wb2.Name
Then
bDateiNum2 = iWorkbook
End
If
Next
iWorkbook
End
Sub
Private
Sub
Vergleich_Arbeitsmappen()
Dim
intWB
As
Integer
, intWS
As
Integer
Dim
objDic
As
Object
Dim
regObj
As
Range
Set
objDic = CreateObject(
"scripting.dictionary"
)
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
For
Each
regObj
In
Workbooks(sDateiName1).Worksheets(intWS).UsedRange
If
Not
regObj =
""
Then
If
regObj.Value <> Workbooks(sDateiName2).Worksheets(intWS).Range(regObj.Address).Value
Then
For
intWB = bDateiNum1
To
bDateiNum2
Workbooks(intWB).Worksheets(intWS).Activate
ActiveSheet.Range(regObj.Address).Interior.ColorIndex = 3
Next
Else
For
intWB = bDateiNum1
To
bDateiNum2
Workbooks(intWB).Worksheets(intWS).Activate
ActiveSheet.Range(regObj.Address).Interior.ColorIndex = 4
Next
End
If
End
If
Next
Next
End
Sub