|
Tipp 0287
|
Tabellen vergleichen
|
|
|
Autor/Einsender: Datum: |
|
Angie 19.11.2002 |
|
Entwicklungsumgebung: |
|
Excel 97 |
|
|
Mit diesem Beispiel lässt sich der Inhalt der Zellen (Formatierungen usw. wurden also nicht berücksichtigt)
zweier Tabellenblätter vergleichen. Hier wird das Ergebnis des Vergleichs in einer neuen Arbeitsmappe ausgegeben.
|
|
|
Public Sub TabellenVergleich(ByVal objWks1 As Worksheet, _
ByVal objWks2 As Worksheet)
Dim objWkbDest As Workbook
Dim objWksDest As Worksheet
Dim optStatusBar As Boolean
Dim lngDiffCnt As Long
Dim lngRowsCnt1 As Long
Dim intColsCnt1 As Integer
Dim lngRowsCnt2 As Long
Dim intColsCnt2 As Integer
Dim lngRowsMax As Long
Dim intColsMax As Integer
Dim strFormula1 As String
Dim strFormula2 As String
Dim nRow As Long
Dim nCol As Integer
Dim lngCounter As Long
Dim strTitle As String
strTitle = "Vergleich '" & objWks1.Name & "' mit '" & _
objWks2.Name & "'"
If Application.WorksheetFunction.CountA(objWks1.Cells) = 0 Then
MsgBox "Das Tabellenblatt '" & objWks1.Name & _
"' enthält keine Daten!", vbInformation, strTitle
Exit Sub
End If
If Application.WorksheetFunction.CountA(objWks2.Cells) = 0 Then
MsgBox "Das Tabellenblatt '" & objWks2.Name & _
"' enthält keine Daten!", vbInformation, strTitle
Exit Sub
End If
Application.ScreenUpdating = False
optStatusBar = Application.StatusBar
Application.StatusBar = True
Application.StatusBar = "Vergleichstabelle wird erstellt..."
Set objWkbDest = Application.Workbooks.Add(xlWBATWorksheet)
Set objWksDest = objWkbDest.Worksheets(1)
With objWks1.UsedRange
lngRowsCnt1 = .Rows.Count
intColsCnt1 = .Columns.Count
End With
With objWks2.UsedRange
lngRowsCnt2 = .Rows.Count
intColsCnt2 = .Columns.Count
End With
If lngRowsCnt1 > lngRowsCnt2 Then
lngRowsMax = lngRowsCnt1
Else
lngRowsMax = lngRowsCnt2
End If
If intColsCnt1 > intColsCnt2 Then
intColsMax = intColsCnt1
Else
intColsMax = intColsCnt2
End If
lngDiffCnt = 0
For nCol = 1 To intColsMax
For nRow = 1 To lngRowsMax
strFormula1 = vbNullString
strFormula2 = vbNullString
strFormula1 = objWks1.Cells(nRow, nCol).FormulaLocal
strFormula2 = objWks2.Cells(nRow, nCol).FormulaLocal
If strFormula1 <> strFormula2 Then
lngDiffCnt = lngDiffCnt + 1
objWksDest.Cells(nRow, nCol).Formula = _
"'" & strFormula1 & " <-> " & strFormula2
End If
lngCounter = lngCounter + 1
Next nRow
Application.StatusBar = "Zellenvergleich... " & _
Format(lngCounter / (intColsMax * lngRowsMax), "0 %")
Next nCol
If lngDiffCnt = 0 Then
objWkbDest.Close SaveChanges:=False
Else
With objWksDest
.Name = "Vergleichsergebnis"
With .Range(.Cells(1, 1), .Cells(lngRowsMax, intColsMax))
.Interior.ColorIndex = 36
.Columns.AutoFit
End With
End With
Application.ActiveWindow.Zoom = 75
End If
Set objWksDest = Nothing
Set objWkbDest = Nothing
Application.StatusBar = vbNullString
Application.StatusBar = optStatusBar
Application.ScreenUpdating = True
MsgBox "Der Inhalt von " & lngDiffCnt & _
" Zellen weichen voneinander ab !", _
vbInformation, strTitle
End Sub
|
|
|
|
|
|
Die im Download befindliche *.bas-Datei kann in Excel im VB-Editor importiert werden.
|
|
Windows-Version |
95 |
|
|
98/SE |
|
|
ME |
|
|
NT |
|
|
2000 |
|
|
XP |
|
|
Vista |
|
|
Win
7 |
|
|
|
Excel-Version |
95 |
|
|
97 |
|
|
2000 |
|
|
2002
(XP) |
|
|
2003 |
|
|
2007 |
|
|
2010 |
|
|
|
|
Download (2,5 kB)
|
Downloads bisher: [ 5159 ]
|
|
|