AW: Formel-Vergleich zwischen zwei Zellen
28.02.2010 18:38:05
Josef
Hallo Tom,
ungetestet!
Der Vergleich läuft nur einseitig, das heißt, die Formelzellen werden nur in der ersten Datei erfasst und mit der Zweiten verglichen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub compareFormulas()
Dim objWbA As Workbook, objWbB As Workbook
Dim objShA As Worksheet, objShB As Worksheet
Dim strFileA As String, strFileB As String
Dim rng As Range, rngFormula As Range, vntRes As Variant
Dim lngIndex As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
strFileA = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Erste Datei auswählen")
If strFileA = CStr(False) Then GoTo ErrExit
strFileB = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Zweite Datei auswählen")
If strFileB = CStr(False) Then GoTo ErrExit
Set objWbA = Workbooks.Open(strFileA)
Set objWbB = Workbooks.Open(strFileB)
lngIndex = lngIndex + 1
Redim vntRes(1 To 3, 1 To lngIndex)
vntRes(1, lngIndex) = "Tabelle/Adresse"
vntRes(2, lngIndex) = objWbA.Name
vntRes(3, lngIndex) = objWbB.Name
For Each objShA In objWbA.Worksheets
If SheetExist(objShA.Name, objWbB) Then
Set objShB = objWbB.Sheets(objShA.Name)
Set rng = Nothing
On Error Resume Next
Set rng = objShA.UsedRange.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
For Each rngFormula In rng
If rngFormula.Formula <> objShB.Range(rngFormula.Address).Formula Then
lngIndex = lngIndex + 1
Redim Preserve vntRes(1 To 3, 1 To lngIndex)
vntRes(1, lngIndex) = objShA.Name & " " & rngFormula.Address(0, 0)
vntRes(2, lngIndex) = "'" & rngFormula.FormulaLocal
vntRes(3, lngIndex) = "'" & objShB.Range(rngFormula.Address).FormulaLocal
End If
Next
End If
End If
Next
objWbA.Close False
objWbB.Close False
With ThisWorkbook.Sheets(1)
.UsedRange.ClearContents
.Rows(1).Font.Bold = True
.Range("A1").Resize(lngIndex, 3) = Application.Transpose(vntRes)
.Columns.AutoFit
End With
ErrExit:
With Err
If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (compareFormulas) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / compareFormulas"
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objShA = Nothing
Set objShB = Nothing
Set objWbA = Nothing
Set objWbB = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Gruß Sepp