AW: Tab vergleichen, farblich hervorheben
16.02.2013 12:12:19
fcs
Hallo Heike,
nachfolgend ein Makro, dass einen solchen Tabellenvergleich mit Farbmakierungen macht.
In der Tabelle "neu" werden zusätzlich in der Spalte neben den Daten die geänderten Zeilen markiert.
Achtung:
Deine hochgeladene Datei enthält hochsensible personenbezogenen Daten. Wenn das echte Daten sind, dann solltest du Hans W. Herber bitten diesen Thread oder zumindest die verlinkte Datei zu löschen.
Du kannst dir großen Ärger einhandeln, wenn diese Daten die Runde machen.
Stichwort: Verstoß gegen das Datenschutzgesetz
Gruß
Franz
Sub VergleichenTabellen()
Dim arrAlt, arrNeu, arrIdAlt, arrIdNeu
Dim wksAlt As Worksheet
Dim wksNeu As Worksheet
Dim Spalte As Long, Spalte_L As Long
Dim ZeilenAlt As Long, ZeilenNeu As Long, varId As Variant, varZeile As Variant
Set wksAlt = Sheets("alt")
'Tabelle1 - anpassen
Set wksNeu = Sheets("neu")
'Tabelle2 - anpassen, in dieser Tabelle wird gekennzeichnet!
With wksAlt
Spalte_L = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Nummer der letzten zu _
vergleichende Spalte
ZeilenAlt = .Cells(.Rows.Count, 1).End(xlUp).Row
arrAlt = .Range(.Cells(1, 1), .Cells(ZeilenAlt, Spalte_L))
arrIdAlt = .Range(.Cells(1, 1), .Cells(ZeilenAlt, 1))
End With
With wksNeu
ZeilenNeu = .Cells(.Rows.Count, 1).End(xlUp).Row
arrNeu = .Range(.Cells(1, 1), .Cells(ZeilenNeu, Spalte_L))
arrIdNeu = .Range(.Cells(1, 1), .Cells(ZeilenNeu, 1))
'Zellfarben im Datenbereich löschen
.Range(.Cells(2, 1), .Cells(ZeilenNeu, Spalte_L)).Interior.ColorIndex = xlColorIndexNone
'Daten in markierungsspalte löschen
.Range(.Columns(Spalte_L + 1), .Columns(Spalte_L + 1)).ClearContents
End With
'Änderungen in neu markieren und nicht mehr vorhandenen in alt
For ZeilenAlt = 2 To ZeilenAlt
varId = arrIdAlt(ZeilenAlt, 1)
'Id im neuen Blatt suchen
varZeile = Application.Match(varId, arrIdNeu, 0)
If IsError(varZeile) Then
With wksAlt
.Range(.Cells(ZeilenAlt, 1), .Cells(ZeilenAlt, Spalte_L)).Interior.ColorIndex = 6
End With
Else
With wksNeu
For Spalte = 1 To Spalte_L
If arrAlt(ZeilenAlt, Spalte) arrNeu(ZeilenAlt, Spalte) Then
wksNeu.Cells(varZeile, Spalte).Interior.ColorIndex = 6
wksNeu.Cells(varZeile, Spalte_L + 1).Value = "geändert" 'Zeile markieren
End If
Next Spalte
End With
End If
Next ZeilenAlt
'Neue Zeilen in Neumarkieren
For ZeilenNeu = 2 To ZeilenNeu
varId = arrIdNeu(ZeilenNeu, 1)
'Id im alten Blatt suchen
varZeile = Application.Match(varId, arrIdAlt, 0)
If IsError(varZeile) Then
With wksNeu
.Range(.Cells(ZeilenNeu, 1), .Cells(ZeilenNeu, Spalte_L)).Interior.ColorIndex = 6
wksNeu.Cells(ZeilenNeu, Spalte_L + 1).Value = "neu" 'Zeile markieren
End With
End If
Next ZeilenNeu
'Arrays zurücksetzen
Erase arrAlt, arrNeu, arrIdAlt, arrIdNeu
End Sub