VBA: 2 Excel Tabellen vergleichen und markieren?
Hallo,
ich habe gesehen, dass es zwar ähnliche Fragen gibt, aber mein Problem konnte ich mit den Antworten bisher nicht lösen. Ich muss dazu sagen, dass ich noch ziemlicher VBA-Neuling bin.
Ich habe 2 Excel Dateien. Diese sind identisch aufgebaut. Das Ergebnis soll in einer dritten Datei geschrieben werden. In Spalte A steht eine eindeutige ID und Spalte B ist ein Erklärungstext hierzu.
Bsp.: Alt:
BS04 Lisa ist 18 Jahre alt.
BS07 Lisa ist einen Apfel.
Neu:
BS07 Lisa isst einen Apfel.
BS08 Lisa wohnt in einem Haus.
Im neuen Dokument wurde BS04 entfernt. BS07 wurde der Schreibfehler korrigiert. BS08 wurde hinzugefügt.
Mein Ziel ist, dass nicht Zeile für Zeile verglichen wird, sondern anhand der ID der Text verglichen wird. Dann sollen Änderungen rot markiert werden. Entfernte Wörter oder entfernte Spalten sollen rot durchgestrichen werden.
Ergebnis:
BS04 Lisa ist 18 Jahre alt. [rot und durchgestrichen]
BS07 Lisa isst einen Apfel. [BS07 rot, das Wort "isst" rot]
BS08 Lisa wohnt in einem Haus. [rot]
Ich habe mir ein Makro bauen können, was ganze Zeilen rot markiert bei Abweichung, leider wird dann alles rot markiert, sobald eine Zeile hinzugefügt bzw. entfernt wurde. Ist ein solches Makro mit VBA überhaupt zu programmieren?
Ich danke euch für eure Mühe!
Gruß Steffen
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:
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
@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!
Ich sehe grad, dass ich die Kommentare nicht bearbeiten kann.
Der Fehler trat auf, weil ich einen schreibfehler im Namen der Tabelle hatte.
Trotzdem taucht jetzt ein neuer Fehler auf. In der 2. Function in der If-Abfrage. --> Laufzeitfehler 1004: Anwendungs- oder objektdefinierter Fehler"
Bei einem Eintrag in "alt", der bei "neu" nicht gefunden wird, liefert die Function gibzeilenindex -1
Das ist kein gültiger Wert mit dem eine Zeile aufgerufen werden kann, das wird ja bei istzeilegleich versucht.
Schnelle Lösung, ich muss dann vielleicht noch in mich gehen, ob es sauberer geht:
Die Function istzeilegleich kannst Du direkt abbrechen, wenn der Wert von zeileneu = - 1 ist. Die vorherige Überprüfung hat ja bereits ergeben, dass der Text in Tabelle "Neu" nicht gefunden wird, also ist er auch nicht gleich.
Nach zu Beginn der Function ergänzen:
If zeileNeu = -1 Then
istZeileGleich = False
Exit Function
End If
Ah. Jetzt funktioniert es sogar. Seltsamerweise mit dem alten und deinem Vorschlag... :). Danke für die schnelle Rückmeldung
Gab auch noch "Rechtschreibproblem" was bei mir zu suchen war...
Was jetzt noch ein Problem ist, wenn IDs neu hinzukommen. D.h. ID ist im Dokument "neu" enthalten. Im alten aber nicht.
Bei mir wird hier immer nur eines erkannt, das am Ende der Tabelle steht. Stehen mehrere am Ende der Tabelle sind diese nicht in der Ergebnistabelle, genau wie eine neue "ID" mitten in der Tabelle.
Die Zeile im Tabellenblatt Ergebnis wird nicht hochgezählt, da fehlt das fettgedruckte:
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
k = k + 1
End If
Next j
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
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!
Ist auch kein Problem. Mit der oben stehenden Lösung kann ich sehr gut arbeiten! Danke für die Mühe!
da ich mich im Umgang mit Matritzen ohnehin verbessern will, bleibe ich trotzdem dran und werde das Ergebnis -sogottwill noch heute oder morgen- hier zur Verfügung stellen. (immerhin weiß ich inzwischen, wie man mehrspaltige Matritzen mit Dim und Redim genauer definiert. Geht halt alles sehr laaaangsaam!
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
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.
In diesem speziellen Fall u. a. bei Wikipedia (https://de.wikipedia.org/wiki/Turing-Vollst%C3%A4ndigkeit).
Ansonsten ist jede Sprache Turing-vollständig, mit der man eine Turing-Maschine simulieren kann (wegen der Äquivalenz aller Turing-vollständigen Maschinen reicht es, die einfachste mögliche Turing-Maschine zu simulieren).
Die wohl wichtigste Voraussetzung ist die Möglichkeit, Schleifen einzurichten, deren Abbruchbedingung erst innerhalb der Schleife berechnet wird.
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!