AW: Tabellen vergleichen
18.01.2006 23:41:21
Peter78
Hallo Sepp,
danke für deine schnelle Antwort.
Ich hatte bis jetzt nicht die Erfahrung gemacht, dass Arrays so schnell sind. Aber das Problem sind ja auch immer die Zellmanipulationen. Ich habe diesbezüglich dein Scriptentwurf auch noch etwas verfeinert.
Das Grundproblem ist aber trotzdem, dass es ja nur einen Vergleich der fixen Zellen durchführt. Wenn mitten im Range eine Zeile eingeschoben wurde, werden alle nachfolgenden als unterschiedlich ausgegeben. Leider habe ich derzeit keine gute Idee, wie man den ja nur verschobenen Teil sicher wieder auffindet. Es können ja beliebig viele Zeilen, Spalten oder gar nur einzelne Zellen eingeschoben worden sein. In solch einem Fall sollen natürlich nur die eingeschobenen Teile/Zellen als unterschiedlich markiert werden und nicht alles nachfolgende.
Ich suche keinen Vergleich von Inhalt _und_ Position sondern lediglich einen inhaltlichen Vergleich!
Hier mein überarbeitetes Script:
(Wie kann man das eigentlich so schön einfügen?)
Option Base 1
Sub vergleichMatrix()
Dim arr1 As Variant
Dim arr2 As Variant
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim n As Long, m As Long, n_end As Long, m_end As Long
Dim ergebnis As Range
Beginn = Now
Application.ScreenUpdating = False
Set wks1 = Sheets("Tabelle1") 'Tabelle1 - anpassen
Set wks2 = Sheets("Tabelle2") 'Tabelle2 - anpassen, in dieser Tabelle wird gekennzeichnet!
arr1 = wks1.UsedRange 'Arrays laden
arr2 = wks2.UsedRange
If UBound(arr1, 2) > UBound(arr2, 2) Then 'ermitteln des größeren Bereichs
m_end = UBound(arr1, 2)
Else
m_end = UBound(arr2, 2)
End If
If UBound(arr1, 1) > UBound(arr2, 1) Then
n_end = UBound(arr1, 1)
Else
n_end = UBound(arr2, 1)
End If
ReDim arr1(n_end, m_end) 'Arrays neu dimensionieren
ReDim arr2(n_end, m_end)
wks1.Activate 'Arrays nach ReDim neu einlesen
arr1 = wks1.Range(Cells(1, 1), Cells(n_end, m_end))
wks2.Activate
arr2 = wks2.Range(Cells(1, 1), Cells(n_end, m_end))
For m = 1 To m_end 'ErgebnisRange bilden
For n = 1 To n_end
If arr1(n, m) <> arr2(n, m) Then
If ergebnis Is Nothing Then
Set ergebnis = wks2.Cells(n, m)
Else
Set ergebnis = Union(ergebnis, wks2.Cells(n, m))
End If
End If
Next
Next
ergebnis.Interior.ColorIndex = 6 'ErgebnisRange manipulieren
Application.ScreenUpdating = True
Antwort = MsgBox("Laufzeit: " & Format(Now - Beginn, "hh:mm:ss"), vbOKOnly) 'Zeitausgabe nur für Testzwecke
End Sub