AW: Tabellenvergl.: Makro funktioniert nicht
21.04.2020 11:27:25
Nepumuk
Hallo Axel,
teste mal:
Option Explicit
Sub ZweiTabellenblätterVergleichen()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wks 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)
With ws1
lngws1Row = .Cells(.Rows.Count, 1).End(xlUp).Row
lngws1Col = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
With ws2
lngws2Row = .Cells(.Rows.Count, 1).End(xlUp).Row
lngws2Col = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
'Eventuelle Farben und Kommentare in Tabelle1 löschen
With ws1.Cells
.Interior.Color = xlNone
.ClearComments
End With
'Eventuelle Farben und Kommentare in Tabelle2 löschen
With ws2.Cells
.Interior.Color = xlNone
.ClearComments
End With
'Maximale Zeilenzahl ermitteln
If lngws1Row > lngws2Row Then
intMaxRow = lngws1Row
Else
intMaxRow = lngws2Row
End If
'Maximale Spaltenzahl ermitteln
If lngws1Col > lngws2Col Then
intMaxCol = lngws1Col
Else
intMaxCol = lngws2Col
End If
'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
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
If Not blnDifferentFound Then _
Call MsgBox("Keinen Unterschied gefunden.", vbInformation, "Info")
'Objekte wieder freigeben
Set ws1 = Nothing
Set ws2 = Nothing
End Sub
Das trägt aber nicht zur Beschleunigung bei.
Gruß
Nepumuk