Vgl. 2 Spalten, abweich. Zeichen färben

Hallo!
Ich muss regelmäßig große Datenbestände miteinander abgleichen. Das heißt den Inhalt einer Spalte mit einer anderen vergleichen, dortige (minimale) Änderungen/Abweichungen im Text erkennen und diese Änderungen sodann in mehrsprachige Übersetzungen einarbeiten. Beispieldatensatz unter https://www.herber.de/bbs/user/138495.txt
Dazu wäre es hilfreich, wenn mir Excel genau jene Zeichen in Zelle A2 und B2 (und natürlich auch in den folgenden Zeilen) rot markiert welche beim Vergleich der beiden Textinhalte voneinander abweichen.
Dazu habe ich bereits folgenden Code gefunden (leider ist mir der Urheber und Ursprung nicht mehr bekannt, sonst würde ich dem Autor durchaus Tribut zollen).


Sub Textfaerben()
Dim strSUCH As String
Dim txtLNGE As Long
Dim i As Long
Dim m As Long
Dim a As Long
Dim rngBereich As Range
Dim rngZelle As Range
Dim Vergleich1 As String
Dim Vergleich2 As String
Dim lngWorte As Long
Set rngBereich = ActiveSheet.Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Set rngBereich = rngBereich.SpecialCells(xlCellTypeConstants, 2)
ActiveSheet.Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row).Font.Color = vbRed
Application.ScreenUpdating = False
For Each rngZelle In rngBereich
m = 1
strSUCH = rngZelle.Offset(0, 1).Value
If strSUCH = rngZelle Then
rngZelle.Font.Color = vbBlack
rngZelle.Offset(0, 1).Font.Color = vbBlack
GoTo WEITER
End If
If Len(strSUCH) > Len(rngZelle) Then
txtLNGE = Len(strSUCH)
Else
txtLNGE = Len(rngZelle)
End If
For i = 2 To txtLNGE
Vergleich1 = Mid(rngZelle.Value, m, i)
Vergleich2 = Mid(rngZelle.Offset(0, 1).Value, m, i)
If Vergleich1 = Vergleich2 Then
rngZelle.Offset(0, 1).Characters(m, i).Font.Color = vbBlack
rngZelle.Characters(m, i).Font.Color = vbBlack
End If
m = m + 1
Next
WEITER:
Next
Application.ScreenUpdating = True
End Sub

Dies funktioniert schon fast mit der Einschränkung, dass das Ganze eigenartigerweise nur bis zur etwa 90sten bzw. 100sten Zeile läuft und bei einer entdeckten Abweichung ALLE weiteren Zeichen nach rechts in der Zelle markiert werden. Schön wär's natürlich wenn nur ein abweichender Bereich markiert wird und die restlichen übereinstimmenden Zeichen in A und B schwarz bleiben ...
Leider überstiegt der Code oben meine VBA Kenntnisse. Sieht jemand auf Anhieb den Fehler?
LG

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Textfaerben() Range("A:B").Font.Color = vbBlack Dim Zelle As Range Dim W1, W2, V1, V2 Dim i As Long Dim z1, z2 As Long Dim s As Long Const Trz = ", " For Each Zelle In Columns(1).SpecialCells(xlCellTypeConstants, 2) If Zelle.Value Zelle.Offset(0, 1).Value Then z1 = 1 z2 = 1 W1 = Split(Zelle.Value, Trz) W2 = Split(Zelle.Offset(0, 1).Value, Trz) For i = 0 To WorksheetFunction.Min(UBound(W1), UBound(W2)) If W1(i) W2(i) Then Zelle.Characters(z1, Len(W1(i))).Font.Color = vbRed Zelle.Offset(0, 1).Characters(z2, Len(W2(i))).Font.Color = vbRed End If z1 = z1 + Len(W1(i)) + 2 z2 = z2 + Len(W2(i)) + 2 Next End If Next End Sub

Hi Daniel,
danke für die schnelle Antwort. Funktioniert leider nicht.
Er steht (wieder) bei


For Each Zelle In Columns(1).SpecialCells(xlCellTypeConstants, 2)
If Zelle.Value  Zelle.Offset(0, 1).Value Then

Hätte es in einer neuen Tabelle mit diversen Inhalten in den Spalten A und B probiert.
... in meiner endgültigen Arbeitstabelle benötige ich diese Abgleich-Funktion steht's für die Spalten G und H. Dafür genügt es, wie ich geprüft hätte, auch nicht einfach den Range in deinem Code auf "G:H" zu setzen ... wär super wenn du mir gegebenenfalls auch hierzu noch Hilfestellung geben könntest.
PS: Wenn ich folgenden Code setze


Const Trz = " "

dann dürfte er die rote Markierung bei einer Abweichung nur bis zum nächsten Leerzeichen fortführen, korrekt?
Vielen Dank für deine Bemühungen vorab.

Beliebteste Forumthreads (12 Monate)

Vgl. 2 Spalten, abweich. Zeichen färben

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread