AW: VBA: 2 Tabellenblätter vergleichen
22.04.2020 07:52:21
Nepumuk
Hallo Axel,
teste mal:
Option Explicit
Public Sub ZweiTabellenVergleichen()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lngws1Row As Long, lngws1Col As Long
Dim lngws2Row As Long, lngws2Col As Long
Dim intMaxRow As Long, intMaxCol As Long
Dim intCol As Long, intRow As Long
Dim strCompWS1 As String, strCompWS2 As String
Dim blnDifferentFound As Boolean
'Referenzierungen
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
'Tabellendimension von Tabelle1 identifizieren
If Not GetLastZell(ws1.Cells, lngws1Row, lngws1Col) Then
Call MsgBox("Keine Zellen in Tabelle 1 gefunden.", vbExclamation, "Hinweis")
Exit Sub
End If
'Tabellendimension von Tabelle2 identifizieren
If Not GetLastZell(ws2.Cells, lngws2Row, lngws2Col) Then
Call MsgBox("Keine Zellen in Tabelle 2 gefunden.", vbExclamation, "Hinweis")
Exit Sub
End If
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'Eventuelle Farben und Kommentare in Tabelle1 löschen
With ws1.Cells
.Interior.Color = xlColorIndexNone
.ClearComments
End With
'Eventuelle Farben und Kommentare in Tabelle2 löschen
With ws2.Cells
.Interior.Color = xlColorIndexNone
.ClearComments
End With
'Maximale Zeilenzahl ermitteln
intMaxRow = Application.Max(lngws1Row, lngws2Row)
'Maximale Spaltenzahl ermitteln
intMaxCol = Application.Max(lngws1Col, lngws2Col)
'Jede Zelle der beiden Tabellenblätter vergleichen
For intCol = 1 To intMaxCol
For intRow = 1 To intMaxRow
strCompWS1 = ws1.Cells(intRow, intCol)
strCompWS2 = ws2.Cells(intRow, intCol)
If strCompWS1 <> strCompWS2 Then
'Wurden Unterschiede gefunden?
blnDifferentFound = True
'Unterschiedliche Einträge in Tabelle1
With ws1.Cells(intRow, intCol)
'Kommentar einfügen
.AddComment strCompWS2
'Kommentierte Zellen markieren
.Interior.ColorIndex = 6 'gelb, 3=rot, 4=grün, 8=türkis
End With
'Unterschiedliche Einträge in Tabelle2
With ws2.Cells(intRow, intCol)
'Kommentar einfügen
.AddComment strCompWS1
'Kommentierte Zellen markieren
.Interior.ColorIndex = 6 'gelb, 3=rot, 4=grün, 8=türkis
End With
End If
Next intRow
Next intCol
'Bildschirmaktualisierung einschalten
Application.ScreenUpdating = True
'Wenn keine Unterschiede gefunden wurden, Message Box mit Hinweis ausgeben
If Not blnDifferentFound Then _
Call MsgBox("Keine Unterschiede gefunden.", vbInformation, "Info")
'Objekte wieder freigeben
Set ws1 = Nothing
Set ws2 = Nothing
End Sub
Private Function GetLastZell( _
ByRef probjRange As Range, _
ByRef prlngLastRow As Long, _
ByRef prlngLastColumn As Long, _
Optional ByVal opvblnReturnLastRow As Boolean = True, _
Optional ByVal opvblnReturnLastColumn As Boolean = True) As Boolean
Dim objCell As Range
Dim dblCellsCount As Double
'Anzahl der Zellen im Bereich lesen
dblCellsCount = probjRange.Cells.CountLarge
'Pruefen ob der gesamte Bereich nicht leer ist
If Application.CountBlank(probjRange) <> dblCellsCount Then
With probjRange
If opvblnReturnLastRow Then
Set objCell = .Find(What:="*", LookIn:=xlValues, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
prlngLastRow = objCell.Row
GetLastZell = True
End If
If opvblnReturnLastColumn Then
Set objCell = .Find(What:="*", LookIn:=xlValues, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
prlngLastColumn = objCell.Column
GetLastZell = True
End If
End With
Set objCell = Nothing
End If
End Function
Gruß
Nepumuk