AW: Dateien vergleichen (Zeileninhalte)
30.07.2008 10:24:00
fcs
Hallo TheMa,
wenn du zeilenweise vergleichen möchtest/kannst, dann kannst du mit dem folgenden Makro als Startpunkt arbeiten.
Falls die Dateien unterschiedlich sortiert sind oder eine Spalte ein Schlüsselfeld enthält das jede Zeile eindeutig kennzeichnet, dann muss man den Vergleich anders aufbauen.
Dann muss das Schlüsselfeld aus der Vergleichsdatei im Original gesucht werden und dann die Zeilen verglichen werden.
Noch komplizierter wird es, wenn man auch die Zeilen erfassen/markieren will, die im Original vorhanden, in der Vergleichsdatei aber gelöscht wurden.
Gruß
Franz
Sub Vergleich()
Dim wbOriginal As Workbook, wbVergleich As Workbook
Dim varDateiname
Dim wksOriginal As Worksheet, wksVergleich As Worksheet
Dim lngZeile As Long, lngSpalte As Long
Const lngFarbe As Long = 6 'gelb = markierfarbe für Unterschiede
'Original-Datei schreibgeschützt öffnen
varDateiname = Application.GetOpenFilename(Filefilter:="Exceldatei (*.xls), *.xls", _
Title:="Bitte Originaldatei öffnen")
If varDateiname = False Then Exit Sub
Set wbOriginal = Application.Workbooks.Open(Filename:=varDateiname, ReadOnly:=True)
'Vergleich-Datei öffnen
varDateiname = Application.GetOpenFilename(Filefilter:="Exceldatei (*.xls), *.xls", _
Title:="Bitte Vergleichdatei öffnen")
If varDateiname = False Then
wbOriginal.Close savechanges = False
Exit Sub
End If
Set wbVergleich = Application.Workbooks.Open(Filename:=varDateiname)
'zu vergleichende Tabellen setzen
Set wksOriginal = wbOriginal.Worksheets(1) 'Datei-Original 1. Tabelle
Set wksVergleich = wbVergleich.Worksheets(1) 'Vergleich-Original 1. Tabelle
Application.ScreenUpdating = False
'Tabellen vergleichen und in Vergleichtabelle markieren
With wksVergleich
For lngZeile = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row
For lngSpalte = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
If .Cells(lngZeile, lngSpalte).Value wksOriginal.Cells(lngZeile, lngSpalte).Value _
Then
.Cells(lngZeile, lngSpalte).Interior.ColorIndex = lngFarbe
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub