AW: Tabellen vergleichen und markieren
08.04.2020 14:31:41
fcs
Hallo Sepp,
hier ein Makro für einen Vergleich von Tabellen mit identischem Spaltenaufbau.
LG
Franz
Sub prcVergleich_Tabellen()
Dim wksNeu As Worksheet, wksAlt As Worksheet
Dim spaKey As Long, spaV As Long, spaV1 As Long, spaV2 As Long
Dim lngAltNeu As Long
Dim zeiAlt As Long, zeiNeu As Long
Dim zeiLast_A As Long, zeiLast_N As Long
Dim arrNeu, arrAlt
Dim bolFound As Boolean, bolChanged As Boolean
Dim farbeNeu As Long, farbeGeaendert As Long
spaKey = 12 'Spalte L - Spalte mit eindeutigen Werten
spaV1 = 13 'Spalte M - 1. zu vergleichende Spalte
spaV2 = 26 'Spalte 2 - letzte zu vergleichende Spalte
farbeNeu = RGB(0, 255, 255) 'hellblau
farbeGeaendert = RGB(255, 0, 0) 'rot
Set wksAlt = ActiveWorkbook.Worksheets("Alte Daten")
Set wksNeu = ActiveWorkbook.Worksheets("Neue Daten")
With wksAlt
zeiLast_A = .Cells(.Rows.Count, spaKey).End(xlUp).Row
arrAlt = .Range(.Cells(1, 1), .Cells(zeiLast_A, spaV2))
lngAltNeu = zeiLast_A 'letzte Datenzeile merken zum Anfügen neuer Datensätze
'Füllfarbe im Datenbereich von Alt löschen
.Range(.Cells(2, spaKey), _
.Cells(zeiLast_A, spaV2)).Interior.ColorIndex = xlColorIndexNone
End With
With wksNeu
zeiLast_N = .Cells(.Rows.Count, spaKey).End(xlUp).Row
arrNeu = .Range(.Cells(1, 1), .Cells(zeiLast_N, spaV2))
End With
'Vergleichen der vorhandenen Daten in Alt
For zeiAlt = 2 To zeiLast_A
bolFound = False
For zeiNeu = 2 To zeiLast_N
If arrAlt(zeiAlt, spaKey) = arrNeu(zeiNeu, spaKey) Then
bolFound = True
bolChanged = False
For spaV = spaV1 To spaV2
If arrAlt(zeiAlt, spaV) arrNeu(zeiNeu, spaV) Then
bolChanged = True
With wksAlt.Cells(zeiAlt, spaV)
.Value = arrNeu(zeiNeu, spaV)
.Interior.Color = farbeGeaendert
End With
End If
Next spaV
If bolChanged = True Then
wksAlt.Cells(zeiAlt, spaKey).Interior.Color = farbeGeaendert
End If
Exit For
End If
Next zeiNeu
If bolFound = False Then
wksAlt.Cells(zeiAlt, spaKey).ClearContents 'markiert zu löschende Zeilen
End If
Next zeiAlt
'Früfen, ob Daten in Neu in Alt fehlen
For zeiNeu = 2 To zeiLast_N
bolFound = False
For zeiAlt = 2 To zeiLast_A
If arrAlt(zeiAlt, spaKey) = arrNeu(zeiNeu, spaKey) Then
bolFound = True
Exit For
End If
Next zeiAlt
If bolFound = False Then
lngAltNeu = lngAltNeu + 1
wksNeu.Rows(zeiNeu).Copy wksAlt.Cells(lngAltNeu, 1)
wksAlt.Cells(lngAltNeu, spaKey).Interior.Color = farbeNeu
End If
Next zeiNeu
'nicht mehr vorhandene Datensätze löschen
With wksAlt
With .Range(.Cells(2, spaKey), .Cells(zeiLast_A, spaKey))
If Application.WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete shift:=xlShiftUp
End If
End With
End With
End Sub