Option Explicit
'ab EXCEL 2003
Sub ZweiMappenVergleichen()
Dim wb1 As Workbook, ws1 As Worksheet, bwb1SchonOffen As Boolean
Dim wb2 As Workbook, ws2 As Worksheet, bwb2SchonOffen As Boolean
Dim sDateiNameFull1 As String, sPfad1 As String, sDateiName1 As String
Dim sDateiNameFull2 As String, sPfad2 As String, sDateiName2 As String
If Not EineXLSDateiAuswaehlen(1. Datei auswählen, sDateiNameFull1, sPfad1, sDateiName1) Then Exit Sub
If Not EineXLSDateiAuswaehlen(2. Datei auswählen, sDateiNameFull2, sPfad2, sDateiName2) Then Exit Sub
If sDateiName1 = sDateiName2 Then MsgBox 2 Dateien mit gleichem Namen geht nicht.: Exit Sub
If Not EineDateiZumLesenOeffnen(sPfad1, sDateiName1, wb1, bwb1SchonOffen) Then Exit Sub
If Not EineDateiZumLesenOeffnen(sPfad2, sDateiName2, wb2, bwb2SchonOffen) Then Exit Sub
If Not ZweiDateienBlaetterEigenschaftenVergleichen(wb1, wb2) Then Exit Sub
Call ZweiDateienBlaetterVergleichen(wb1, wb2)
End Sub
'*************************************************************************************************************
Private Function ZweiDateienBlaetterVergleichen(wbx As Workbook, wby As Workbook)
->Liefert eine Protokolldatei der Differenzen. Der Vergleich erfolgt Zeilenweise.
->Wird ein Unterschied festgestellt, so werden
-> - Blattname
-> - Zeilenr
-> - Art des Unterschiedes: Value und/oder Formel
-> die Zeile aus x
-> die Zeile aus y
-> Die unterschiedlichen Zellen werden farblich markiert
-> gelb - nur Value unterschiedlich
Const cFARBIND_VALUE = 36 ->hellgelb
-> blau - nur Formel unterschiedlich
Const cFARBIND_FORMEL = 34 ->hellblau
-> orage - Formel und Value unterschiedlich
Const cFARBIND_FORMEL_UND_VALUE = 40->orange
->
-> Pro Blatt ist die Anzahl der angezeigten unterschiedlichen Zeilen auf 300 begrenzt
Const cANZMAX_PROBLATT = 300
->
-> Bei mehr als 3000 Unterschieden insgesamt ist Schluß
Const cANZMAX_GESAMT = 3000
->
Const cSP_Blattname = 1
Const cSP_Zeile = cSP_Blattname + 1
Const cSP_DiffValue = cSP_Zeile + 1
Const cSP_DiffFormel = cSP_DiffValue + 1
Const cSP_AnfangZeile = cSP_DiffFormel + 1
Dim wbz As Workbook, wsz As Worksheet, wsx As Worksheet, wsy As Worksheet
Dim lDiff_Gesamt As Long, lDiff_Blatt As Long
Dim lRowsx As Long, lColsx As Long, lRowsy As Long, lColsy As Long, lRows As Long, lCols As Long
Dim c As Long, r As Long, x As Long, z As Long
Dim lDiff_Cols_Value() As Boolean, lDiff_Cols_Formel() As Boolean
Dim bFormelx As Boolean, bFormely As Boolean, bDiffCols_value As Boolean, bDiffCols_formel As Boolean
->Protokoll-Datei mit Protokoll-Blatt, Text-Format
Set wbz = Workbooks.Add
Application.DisplayAlerts = False
For x = wbz.Worksheets.Count To 2 Step -1: wbz.Worksheets(x).Delete: Next
Application.DisplayAlerts = True
Set wsz = wbz.Worksheets(1)
wsz.Cells.NumberFormat = @
z = 1
wsz.Rows(1).Cells.Font.Bold = True
wsz.Cells.HorizontalAlignment = xlLeft
wsz.Cells.VerticalAlignment = xlTop
wsz.Cells(z, cSP_Blattname).Value = Blattname
wsz.Cells(z, cSP_Zeile).Value = Zeile
wsz.Cells(z, cSP_DiffValue).Value = Diff & vbLf & Value
wsz.Cells(z, cSP_DiffFormel).Value = Diff & vbLf & Formel
lDiff_Gesamt = 0
For Each wsx In wbx.Worksheets
lRowsx = wsx.UsedRange.Rows.Count + wsx.UsedRange.Row - 1
lColsx = wsx.UsedRange.Columns.Count + wsx.UsedRange.Column - 1
Set wsy = wby.Worksheets(wsx.Name)
lRowsy = wsy.UsedRange.Rows.Count + wsy.UsedRange.Row - 1
lColsy = wsy.UsedRange.Columns.Count + wsy.UsedRange.Column - 1
If lRowsx < lRowsy Then lRows = lRowsy Else lRows = lRowsx
If lColsx < lColsy Then lCols = lColsy Else lCols = lColsx
lDiff_Blatt = 0
->zu vergleichender Bereich LRows, lCols
For r = 1 To lRows
ReDim lDiff_Cols_Value(1 To lCols)
ReDim lDiff_Cols_Formel(1 To lCols)
bDiffCols_value = False
bDiffCols_formel = False
For c = 1 To lCols
->Value gleich ?
If wsx.Cells(r, c).Value <> wsy.Cells(r, c).Value Then lDiff_Cols_Value(c) = True: bDiffCols_value = True
->Formel gleich ?
bFormelx = wsx.Range(wsx.Cells(r, c), wsx.Cells(r, c)).HasFormula
bFormely = wsy.Range(wsy.Cells(r, c), wsy.Cells(r, c)).HasFormula
If bFormelx <> bFormelx Then lDiff_Cols_Formel(c) = True: bDiffCols_formel = True
If bFormelx And bFormely Then
If wsx.Cells(r, c).Formula <> wsy.Cells(r, c).Formula Then lDiff_Cols_Formel(c) = True: bDiffCols_formel = True
End If
Next
->Differenzen ?
If bDiffCols_value Or bDiffCols_formel Then
->ZeilenDifferenz auf Protokoll-Datei ausgeben
z = z + 1
wsz.Cells(z, cSP_Blattname).Value = wsx.Name
wsz.Cells(z, cSP_Zeile).Value = r
If bDiffCols_value Then wsz.Cells(z, cSP_DiffValue).Value = x
If bDiffCols_formel Then wsz.Cells(z, cSP_DiffFormel).Value = x
->betroffene Zeilenn kopieren
z = z + 1
wsx.Range(wsx.Cells(r, 1), wsx.Cells(r, lCols)).Copy
wsz.Cells(z, cSP_AnfangZeile).PasteSpecial _
Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
z = z + 1
wsy.Range(wsy.Cells(r, 1), wsy.Cells(r, lCols)).Copy
wsz.Cells(z, cSP_AnfangZeile).PasteSpecial _
Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
->unterschiedliche Zellen farblich kennzeichnen
For x = 1 To lCols
If lDiff_Cols_Formel(x) And lDiff_Cols_Value(x) Then
wsz.Cells(z, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL_UND_VALUE
wsz.Cells(z - 1, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL_UND_VALUE
ElseIf lDiff_Cols_Formel(x) Then
wsz.Cells(z, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL
wsz.Cells(z - 1, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL
ElseIf lDiff_Cols_Value(x) Then
wsz.Cells(z, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_VALUE
wsz.Cells(z - 1, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_VALUE
End If
Next
->Differenzenzähler
lDiff_Blatt = lDiff_Blatt + 1
lDiff_Gesamt = lDiff_Gesamt + 1
If lDiff_Gesamt >= cANZMAX_GESAMT Then GoTo AUFRAEUMEN
If lDiff_Blatt >= cANZMAX_PROBLATT Then Exit For
End If
Next
Next
AUFRAEUMEN:
If lDiff_Gesamt = 0 Then
wbz.Close SaveChanges:=False: MsgBox Keine Unterschiede vorhanden.
Else
For x = 1 To cSP_AnfangZeile - 1: wsz.Columns(x).AutoFit: Next
End If
Set wsx = Nothing: Set wsy = Nothing: Set wsz = Nothing: Set wbz = Nothing
End Function
'*************************************************************************************************************
Private Function ZweiDateienBlaetterEigenschaftenVergleichen(wbx As Workbook, wby As Workbook) As Boolean
->liefert true, wenn jeder Blattname der einen Datei auch in der anderen enthalten ist
->und jeweils beide Blätter die gleiche->sichtbar' Eigenschaft haben
Dim wsx As Worksheet, wsy As Worksheet
Dim sMx() As String, sMxCnt As Long: ReDim sMx(1 To 1)
Dim sVisibleX As String, sVisibleY As String
Dim bFound As Boolean
Dim x As Long
For Each wsx In wbx.Worksheets
bFound = False
For Each wsy In wby.Worksheets
If LCase(wsy.Name) = LCase(wsx.Name) Then
bFound = True
If wsx.Visible <> wsy.Visible Then
Select Case wsy.Visible
Case xlSheetHidden: sVisibleY = versteckt
Case xlSheetVeryHidden: sVisibleY = ganz versteckt
Case xlSheetVisible: sVisibleY = sichtbar
End Select
Select Case wsx.Visible
Case xlSheetHidden: sVisibleX = versteckt
Case xlSheetVeryHidden: sVisibleX = ganz versteckt
Case xlSheetVisible: sVisibleX = sichtbar
End Select
sMxCnt = sMxCnt + 1: ReDim Preserve sMx(1 To sMxCnt)
sMx(sMxCnt) = Blatt: & wsx.Name & vbLf & _
in Datei: & wbx.Name & & sVisibleX & vbLf & _
in Datei: & wby.Name & & sVisibleY
End If
Exit For
End If
Next
If Not bFound Then
sMxCnt = sMxCnt + 1: ReDim Preserve sMx(1 To sMxCnt)
sMx(sMxCnt) = _
Datei: & wbx.Name & Blatt: & wsx.Name & vbLf & _
in Datei: & wby.Name & nicht vorhanden.
End If
Next
For Each wsy In wby.Worksheets
bFound = False
For Each wsx In wbx.Worksheets
If LCase(wsy.Name) = LCase(wsx.Name) Then bFound = True: Exit For
Next
If Not bFound Then
sMxCnt = sMxCnt + 1: ReDim Preserve sMx(1 To sMxCnt)
sMx(sMxCnt) = _
Datei: & wby.Name & Blatt: & wsy.Name & vbLf & _
in Datei: & wbx.Name & nicht vorhanden.
End If
Next
If sMxCnt > 0 Then
MsgBox Beim Vergleich der Blattnamen und Eigenschaften sind & sMxCnt & Unterschiede erkannt worden.
For x = 1 To sMxCnt: MsgBox sMx(x): Next
Else
ZweiDateienBlaetterEigenschaftenVergleichen = True
End If
AUFRAEUMEN:
Set wsx = Nothing: Set wsy = Nothing
End Function
'*************************************************************************************************************
Private Function EineDateiZumLesenOeffnen(sPfad As String, _
sDateiname As String, _
wb As Workbook, _
bwbSchonOffen) As Boolean
->pruefen, ob Datei bereits geöffnet ist
Dim wbx As Workbook
For Each wbx In Workbooks
If wbx.Name = sDateiname Then
Set wb = wbx
bwbSchonOffen = True
EineDateiZumLesenOeffnen = True
GoTo AUFRAEUMEN
End If
Next
bwbSchonOffen = False
On Error Resume Next
Set wb = Nothing
Set wb = Workbooks.Open( _
Filename:=sPfad & Application.PathSeparator & sDateiname, _
UpdateLinks:=False, _
ReadOnly:=True)
On Error GoTo 0
If wb Is Nothing Then
MsgBox _
Datei konnte nicht geöffnet werden. & vbLf & _
sPfad & Application.PathSeparator & sDateiname
GoTo AUFRAEUMEN
End If
EineDateiZumLesenOeffnen = True
AUFRAEUMEN:
Set wbx = Nothing
End Function
'*************************************************************************************************************
Private Function EineXLSDateiAuswaehlen(sTitel As String, _
sDateiNameFull As String, _
sPfad As String, _
sDateiname As String) As Boolean
Dim oDlgOpen As FileDialog
Dim sTmp() As String
Set oDlgOpen = Application.FileDialog(msoFileDialogFilePicker)
->msoFileDialogOpen, msoFileDialogSaveAs, msoFileDialogFolderPicker, msoFileDialogFilePicker,
oDlgOpen.AllowMultiSelect = False
oDlgOpen.Filters.Clear
oDlgOpen.Filters.Add EXCEL, *.xls, 1
oDlgOpen.InitialView = msoFileDialogViewList->msoFileDialogViewDetails
oDlgOpen.Title = Datei auswählen
oDlgOpen.Show
If oDlgOpen.SelectedItems.Count = 0 Then GoTo AUFRAEUMEN
sDateiNameFull = oDlgOpen.SelectedItems(1)
sTmp = Split(sDateiNameFull, Application.PathSeparator)
sDateiname = sTmp(UBound(sTmp()))
sPfad = Left(sDateiNameFull, Len(sDateiNameFull) - Len(sDateiname))
If Right(sPfad, 1) = Application.PathSeparator Then sPfad = Left(sPfad, Len(sPfad) - 1)
EineXLSDateiAuswaehlen = True
AUFRAEUMEN:
Set oDlgOpen = Nothing
End Function
