VBA: 2 Excel Tabellen vergleichen und markieren?

...komplette Frage anzeigen

4 Antworten

Trivial ist das nicht. Ich habe was gebastelt, allerdings auf Basis einer Datei, die alt, neu und das zusammengeführte Ergebnis in jeweils getrennten Tabellenblättern enthält. Das sollte grundsätzlich auch zwischen drei Exceldateien gehen, ist aber fummelig, gerade beim Ausprobieren. Ich würde es ehrlich gesagt weiterhin in einer Datei erledigen - wenn das manuelle Kopieren nicht tragfähig ist, kann man mit VBA auch die Tabelleninhalte in einer Datei zusammenkopieren bzw. über eine Datenverbindung reinziehen.

Was zumindest für mich mit meinen Kenntnissen nicht zu lösen ist, ist die Anforderung einen unterschiedlichen Inhalt auf Buchstabenebene zu markieren. Ich habe auf die Schnelle auch keine Umsetzung in VBA im Internet gefunden. Ab der ersten Abweichung mit einem Buchstaben mehr oder weniger reicht es nicht mehr aus einfach Stelle für Stelle zu vergleichen. Ich habe für einen ersten Wurf das Verfahren hier geklaut:

http://www.herber.de/forum/archiv/1260to1264/1260531_Textvergleich_mit_Markierung_der_Unterschiede.html

Die Lösung für die Formatierungen gefällt mir irgendwie noch nicht, scheint nach meinen Tests aber zumindest zu funktionieren.

Sub zusammenstellen()
Dim alt, neu, ergebnis, vergleich1, vergleich2 As String
alt = "Alt" 'name des tabellenblatts mit den alten einträgen
neu = "Neu" ' name tabblatt neue einträge
ergebnis = "Ergebnis" 'name tabblatt ergebnisse der zusammenführung
Dim i, j, k As Long
k = 1
'zunächst das tabellenblatt alt durchgehen
For i = 1 To Sheets(alt).Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Sheets(neu).Range("A:A"), Sheets(alt).Cells(i, 1).Value) = 0 Then 'wenn nicht im tabellenblatt neu gefunden
Sheets(ergebnis).Cells(k, 1).Value = Sheets(alt).Cells(i, 1).Value
Sheets(ergebnis).Cells(k, 2).Value = Sheets(alt).Cells(i, 2).Value
Sheets(ergebnis).Cells(k, 1).Font.Strikethrough = True
Sheets(ergebnis).Cells(k, 1).Font.Color = vbred
Sheets(ergebnis).Cells(k, 2).Font.Strikethrough = True
Sheets(ergebnis).Cells(k, 2).Font.Color = vbred
Else
'für die einträge aus "alt", die in "neu" enthalten sind prüfen ob der inhalt der 2. spalte auch gleich ist
For j = 1 To Sheets(neu).Cells(Rows.Count, 1).End(xlUp).Row
If Sheets(alt).Cells(i, 1).Value = Sheets(neu).Cells(j, 1).Value Then
Sheets(ergebnis).Cells(k, 1).Value = Sheets(neu).Cells(j, 1).Value
Sheets(ergebnis).Cells(k, 2).Value = Sheets(neu).Cells(j, 2).Value
If Sheets(alt).Cells(i, 2).Value = Sheets(neu).Cells(j, 2).Value Then 'wenn gleich:
Sheets(ergebnis).Cells(k, 1).Font.Color = vbBlack
Sheets(ergebnis).Cells(k, 2).Font.Color = vbBlack
Else 'wenn anderer inhalt in der 2. Spalte:
Sheets(ergebnis).Cells(k, 1).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 2).Font.Color = vbRed
' hier die notdürftige lösung um die unterschiede zu markieren: http://www.herber.de/forum/archiv/1260to1264/1260531_Textvergleich_mit_Markierung_der_Unterschiede.html
If Len(Sheets(alt).Cells(i, 2).Value) > Len(Sheets(ergebnis).Cells(k, 2).Value) Then
txtlen = Len(Sheets(alt).Cells(i, 2).Value)
Else
txtlen = Len(Sheets(ergebnis).Cells(k, 2).Value)
End If
m = 1
For l = 2 To txtlen
vergleich1 = Mid(Sheets(alt).Cells(i, 2).Value, m, l)
vergleich2 = Mid(Sheets(ergebnis).Cells(k, 2).Value, m, l)
If vergleich1 = vergleich2 Then
Sheets(ergebnis).Cells(k, 2).Characters(m, l).Font.Color = vbBlack
End If
m = m + 1
Next
End If
Else
End If
Next j
End If
k = k + 1
Next i
'die neuen Einträge noch ergänzen, d.h. die nicht auf tabellenblatt "alt" stehen
For j = 1 To Sheets(neu).Cells(Rows.Count, 1).End(xlUp).Row 'tabelle "neu" durchgehen
If WorksheetFunction.CountIf(Sheets(alt).Range("A:A"), Sheets(neu).Cells(j, 1).Value) = 0 Then 'prüfen ob auf tab. "alt" vorhanden
Sheets(ergebnis).Cells(k, 1).Value = Sheets(neu).Cells(j, 1).Value
Sheets(ergebnis).Cells(k, 2).Value = Sheets(neu).Cells(j, 2).Value
Sheets(ergebnis).Cells(k, 1).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 2).Font.Color = vbRed
k = k + 1
End If
Next j

End Sub
Antwort bewerten Vielen Dank für Deine Bewertung
Kommentar von Iamiam
11.08.2016, 20:38

@Ninombre: DH! auch wenns "geklaut" ist, so ist es doch gefunden! Übrigens noch

Else
.(Zelle).Characters(Start:=.., Length:=1).Font.Strikethrough = True
.(Zelle).Characters(Start:=.., Length:=1).Font.Color = vbblue

im Zellvergleich einfügen. Hab vbblue genommen, weil später die ganzen Zellen evtl mit vbred markiert werden. Hab jetzt aber nicht die Konzentration, mich intensiver drum zu kümmern.

@DefSteff22: Da sich die Längen auch positiv wie negativ ändern können (aber nicht müssen) und Doppelbuchstaben trotzdem noch möglich sind, können ab der Korrekturstelle ALLE folgenden Zeichen abweichen (also undefiniert, siehe Anm. unten). Das zu korrigieren, wäre extrem aufwändig.

Man könnte die Korrektur auf den Rest einzelner Wörter begrenzen, aber auch die Auflösung in Wörter ist recht aufwändig. Für ein Übungsprogramm eindeutig mindestens eine Nummer zu hoch gegriffen!

Anm: man könnte natürlich die Übereinstimmung von zB Zeichen5 mit Zeichen4 und Zeichen6 des Vergleichstexts prüfen, aber eben bei Doppelbuchstaben würde auch das falsch. evtl den Rest der Zelle gleicher Länge, es gibt so viele Optionen, aber alle sind sehr aufwändig!

1
Kommentar von DefSteff22
15.08.2016, 13:51

Ich hoffe das hier liest noch jemand :).

Habe diesen Code für eine andere Anwendung angepasst. Leider kommt bei mir jetzt eine Fehlermeldung mit der ich nichts anfangen kann.

Ziel: In Spalte A steht eine eindeutige ID. Ist diese nur in Tabellenblatt "neu" oder "alt" enthalten, soll der Text in der ganzen Zeile rot werden. Gibt es eine Abweichung in einer Spalte der Zeile, soll auch die ganze Zeile rot werden.

Der Debugger markiert bei mir immer die Zeile:

For i = 1 To Sheets(alt).Cells(Rows.Count, 1).End(xlUp).Row mit der Meldung "Index außerhalb des gültigen Bereichs". Leider habe ich keine Idee warum. 

Danke euch und noch einen schönen Montag!

Sub Req()
Dim alt, neu, ergebnis, vergleich1, vergleich2 As String
alt = "Reqalt" 'name des tabellenblatts mit den alten einträgen
neu = "Req" ' name tabblatt neue einträge
ergebnis = "Ergebnis" 'name tabblatt ergebnisse der zusammenführung
Dim i, j, k As Integer
k = 1
'zunächst das tabellenblatt alt durchgehen
For i = 1 To Sheets(alt).Cells(Rows.Count, 1).End(xlUp).Row

Dim zeileNeu As Integer
zeileNeu = gibZeilenIndex(Sheets(neu), Sheets(alt).Cells(i, 1).Value)

Sheets(ergebnis).Cells(k, 1).Value = Sheets(alt).Cells(i, 1).Value
Sheets(ergebnis).Cells(k, 2).Value = Sheets(alt).Cells(i, 2).Value
Sheets(ergebnis).Cells(k, 3).Value = Sheets(alt).Cells(i, 3).Value
Sheets(ergebnis).Cells(k, 4).Value = Sheets(alt).Cells(i, 4).Value
Sheets(ergebnis).Cells(k, 5).Value = Sheets(alt).Cells(i, 5).Value

If Not istZeileGleich(Sheets(alt), i, Sheets(neu), zeileNeu) Then
Sheets(ergebnis).Cells(k, 1).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 2).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 3).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 4).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 5).Font.Color = vbRed
Else 'um alte formatierungen zu überschreiben
Sheets(ergebnis).Cells(k, 1).Font.Color = vbBlack
Sheets(ergebnis).Cells(k, 2).Font.Color = vbBlack
Sheets(ergebnis).Cells(k, 3).Font.Color = vbBlack
Sheets(ergebnis).Cells(k, 4).Font.Color = vbBlack
Sheets(ergebnis).Cells(k, 5).Font.Color = vbBlack
End If

k = k + 1

Next i

'die neuen Einträge noch ergänzen, d.h. die nicht auf tabellenblatt "alt" stehen
For j = 1 To Sheets(neu).Cells(Rows.Count, 1).End(xlUp).Row 'tabelle "neu" durchgehen
If WorksheetFunction.CountIf(Sheets(alt).Range("A:A"), Sheets(neu).Cells(j, 1).Value) = 0 Then 'prüfen ob auf tab. "alt" vorhanden
Sheets(ergebnis).Cells(k, 1).Value = Sheets(neu).Cells(j, 1).Value
Sheets(ergebnis).Cells(k, 2).Value = Sheets(neu).Cells(j, 2).Value
Sheets(ergebnis).Cells(k, 3).Value = Sheets(neu).Cells(j, 3).Value
Sheets(ergebnis).Cells(k, 4).Value = Sheets(neu).Cells(j, 4).Value
Sheets(ergebnis).Cells(k, 5).Value = Sheets(neu).Cells(j, 5).Value
Sheets(ergebnis).Cells(k, 1).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 2).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 3).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 4).Font.Color = vbRed
Sheets(ergebnis).Cells(k, 5).Font.Color = vbRed
End If
Next j
End Sub

Function gibZeilenIndex(sheet As Worksheet, text As String) As Integer

gibZeilenIndex = -1

Dim zeile As Integer
For zeile = 1 To sheet.Cells(Rows.Count, 1).End(xlUp).Row
If sheet.Cells(zeile, 1).Value = text Then
gibZeilenIndex = zeile
End If
Next zeile

End Function

Function istZeileGleich(sheetAlt As Worksheet, ByVal zeileAlt As Integer, sheetNeu As Worksheet, zeileNeu As Integer) As Boolean

istZeileGleich = True

Dim spalte As Integer
For spalte = 1 To 6 Step 1
If sheetAlt.Cells(zeileAlt, spalte).Value <> sheetNeu.Cells(zeileNeu, spalte).Value Then
istZeileGleich = False
End If
Next spalte

End Function
0

VBA ist Turing-vollständig, d. h. damit kannst du alles machen, was überhaupt mit irgendeinem Computer gemacht werden kann.

VBA ist auch als Programmiersprache "erwachsen" genug, dass das mit vertretbarem Aufwand passieren kann.

Aber: "vertretbarer Aufwand" ist sehr relativ. Für einen ersten Eindruck würde ich einen Blick auf den Quellcode von diff-Tools empfehlen. Z. B. windiff, dessen Quellcode bei Visual Studio 6 mit dabei war.

Antwort bewerten Vielen Dank für Deine Bewertung
Kommentar von Iamiam
12.08.2016, 12:40

Turing-vollständig: gut zu wissen! Wo findet man sowas?

0

dan Markierungsteil hab ich so lala hingebogen gekriegt, und weil ich die Nase jetzt gestrichen voll hab, kopiere ich eben die Rohfassung ein als Anregung, wenn Du/Sonstjemand das weiterverfolgen will.

Abweichende Wörter werden erkannt und vllt nicht ganz richtig markiert, Worttrennungen (Auseinanderschreiben von vorher zusammengeschriebenen Wörtern verursachen Färbung des gesamten Restes.

Option Explicit: Option Base 1: Option Compare Binary ' !!!

Sub ZellVergleichWörterFärben()
Dim ZelleA As Range, ZelleB As Range, WortzahlA As Integer, WortzahlB As Integer, _
MaxWortZ, Mtx(), i As Integer, Pos As Integer, Wort As String

Set ZelleA = ActiveWorkbook.Worksheets("µs1").Range("O5"): Set ZelleB = ZelleA.Offset(1, 0) 'ActiveWorkbook.Worksheets("µs1").Range("O6")
Debug.Print ZelleA.Address & " A _ B " & ZelleB.Address
'Set ZelleB = Worksheets("µs1").Range("O6"): Debug.Print ZelleA.Value: 'Debug.Print ZelleB.Value

WortzahlA = Len(ZelleA) - Len(Replace(ZelleA, " ", "")) + 1: WortzahlB = Len(ZelleB) - Len(Replace(ZelleB, " ", "")) + 1 'obsolet: ErstB = InStr(" ", ZelleB, 1) '?
MaxWortZ = Application.WorksheetFunction.Max(WortzahlA, WortzahlB) 'k. Max() als VBA-Fkt???
ReDim Mtx(MaxWortZ, MaxWortZ, MaxWortZ, MaxWortZ) 'Matrix-(Array-) Parameter: 4 Spalten=4Argumente, jedes max. Itemzahl

Wort = "": i = 1
For Pos = 1 To Len(ZelleA.Value)
If ZelleA.Characters(Pos, 1).Text = " " Then
Mtx(i, 1, 1, 1) = Wort: 'Debug.Print Wort & " Wort_Mtx(i, 1...) " & Mtx(i, 1, 1, 1)
Wort = "": i = i + 1
Else
Wort = Wort & ZelleA.Characters(Pos, 1).Text: 'Debug.Print Wort & " Wort _ akt. Z:" & Mid(ZelleA, Pos, 1) 'hätt ich mir was sparen können!
End If
Next

Wort = "": i = 1
For Pos = 1 To Len(ZelleB.Value)
If ZelleB.Characters(Pos, 1).Text = " " Then
Mtx(1, i, 1, 1) = Wort: 'Debug.Print " Wort_Mtx(i, 1...) " & Mtx(1, i, 1, 1)
Wort = "": i = i + 1
Else
Wort = Wort & ZelleB.Characters(Pos, 1).Text: 'Debug.Print Wort & " Wort _ akt. Z:" & Mid(ZelleB, Pos, 1)
End If
Next 'funkt. bis hierher.Matrix A und B gefüllt, C und D notwendig?

'Färben der Buchstaben des abweichenden Wortes:
i = 1: Pos = 1
For i = 1 To MaxWortZ
Pos = Pos + Len(Mtx(1, i, 1, 1)) - i ' mit der genauen Platzierung der Farbmarkierung stimmt noch was nicht, SCHLUSS!
If Mtx(i, 1, 1, 1) <> Mtx(1, i, 1, 1) Then ZelleB.Characters(Pos, Len(Mtx(1, i, 1, 1))).Font.Color = vbRed 'ColorIndex = 3
Next 'warum wird vom letzten Wort nur der Anfang gefärbt?
End Sub

Antwort bewerten Vielen Dank für Deine Bewertung

Ich versuche das noch zu bearbeiten, aber frühestens am So.
Prinzip:
zu vergleichende Zellen festlegen.
wenn identisch => next, ansonsten
Wörter stufenweise "abknabbern" vor Leerzeichen bzw Ende.
abgeknabberte Wörter in Matrix(Anzahl LZ +1, 2[sogar3+4?*]) speichern für beide zu vgl. Zellen
Wörter Vergleichen
bei Nichtident. ZeichenNr festhalten(also vorher auch Wortlängen, evtl. in Mtx(.;.;[3];[4])
(Bei Bedarf Unterschleife für Einzelzeichen, ansonsten ganzes Wort färben)
kann ss=>s oder s=ss etc ohne Fehler verarbeiten

  • Einschränkung: 
  • geänderte Zusammen-/Auseinanderschreibung markiert alle folgenden Wörter als falsch
  • oder aber zusätzlich (auch Zeit-)aufwändiger Vergleich mit Wort n-1 und n+1

Ich lasse mir die Idee auch gerne klauen, wenn jemand anderer das ausarbeiten will

Antwort bewerten Vielen Dank für Deine Bewertung
Kommentar von Iamiam
14.08.2016, 17:57

Hat wohl keiner aufgegriffen, hab selber noch viele Schwierigkeiten mit der speziellen Syntax vieler Befehle (speziel mit der Matrix-Variablen, aber auch mit anderen), wird wohl noch dauern!

0

Was möchtest Du wissen?