AW: Vergleich von Zelleninhalt
29.07.2014 16:11:55
Zelleninhalt
Hallo Tom,
hier mal ein Ansatz.
Probiere mal ein paar Änderungsvarianten aus, ob es ungefähr passt. Weitere Verfeinerungen der Markierungen werden sehr kompliziert in der Programmierung.
Gruß
Franz
Sub Markieren_Aenderungen()
Dim wksData As Worksheet
Dim Zeile As Long, Zeile_L
Dim strText1 As String, strText2 As String
Dim bolPlus1 As Boolean, bolPlus2 As Boolean
Dim FarbePlus As Long, FarbeMinus As Long
Dim Pos11 As Integer, Pos12 As Integer
Dim Pos21 As Integer, Pos22 As Integer
Dim Pos13 As Integer, Pos14 As Integer
Dim Pos23 As Integer, Pos24 As Integer
Dim varSplit1, varSplit2, strWort As String
Dim iWort As Integer, intK
Dim iWort2 As Integer, iWort22 As Integer
FarbePlus = RGB(Red:=0, Green:=0, Blue:=255)
FarbeMinus = RGB(Red:=255, Green:=0, Blue:=0)
Set wksData = ActiveSheet
Application.ScreenUpdating = False
With wksData
Set wksData = ActiveSheet
Zeile_L = .Cells(.Rows.Count, 2).End(xlUp).Row
'Font-Formatierungen zurücksetzen
With .Range(.Cells(7, 1), .Cells(Zeile_L, 3))
With .Font
.ColorIndex = xlColorIndexAutomatic
.Bold = False
End With
End With
'Zeilen ab zeile 7 abarbeiten
For Zeile = 7 To Zeile_L
If .Cells(Zeile, 2).Value = .Cells(Zeile + 1, 2).Value Then
'Code 2 mal vorhanden
bolPlus1 = .Cells(Zeile, 1).Value = "+"
bolPlus2 = .Cells(Zeile + 1, 1).Value = "+"
strText1 = .Cells(Zeile, 3).Value
strText2 = .Cells(Zeile + 1, 3).Value
'Position des 1. abweichenden Zeichens vom Beginn
For Pos11 = 1 To Len(strText1)
If Mid(strText1, Pos11, 1) Mid(strText2, Pos11, 1) Then
Exit For
End If
Next Pos11
Pos21 = Pos11
'Position des letzen abweichenden Zeichens vom Ende
Pos22 = Len(strText2)
For Pos12 = Len(strText1) To 1 Step -1
If Mid(strText1, Pos12, 1) Mid(strText2, Pos22, 1) Then
Exit For
End If
Pos22 = Pos22 - 1
Next Pos12
'Text 1 markieren von 1. bis letzter Änderung
Call prcMarkierenText(Zelle:=.Cells(Zeile, 3), Pos1:=Pos11, Pos2:=Pos12, _
Farbe:=IIf(bolPlus1, FarbePlus, FarbeMinus))
'Text 2 markieren von 1. bis letzter Änderung
Call prcMarkierenText(Zelle:=.Cells(Zeile + 1, 3), Pos1:=Pos21, Pos2:=Pos22, _
Farbe:=IIf(bolPlus2, FarbePlus, FarbeMinus))
'prüfen ob im markierten Bereich Leerzeichen enthalten sind --> mehrere Wörter.
'Markierten Text herausschneiden
strText1 = Mid(strText1, Pos11, Pos12 - Pos11 + 1)
strText2 = Mid(strText2, Pos21, Pos22 - Pos21 + 1)
'prüfen ob im markierten Bereich Leerzeichen enthalten sind --> mehrere Wörter.
If InStr(1, strText1, " ") > 0 And InStr(1, strText2, " ") > 0 Then
'Punkte in den markierten Texten durch Leerzeichen ersetzen
strText1 = VBA.Replace(strText1, ".", " ")
strText2 = VBA.Replace(strText2, ".", " ")
'Texte am Leerzeichen splitten für Wortvergleich
varSplit1 = Split(strText1, " ")
varSplit2 = Split(strText2, " ")
If UBound(varSplit1) > 1 And UBound(varSplit2) > 1 Then
'wortweiser Vergleich nach 1. geänderten Zeichen
iWort2 = 1
For iWort = 1 To UBound(varSplit1) - 1
strWort = varSplit1(iWort)
'Wort im 2. Text suchen
For iWort22 = iWort2 To UBound(varSplit2)
If varSplit2(iWort22) = strWort Then
iWort2 = iWort22
Pos23 = Pos21
For intK = 0 To iWort2 - 1
Pos23 = Pos23 + Len(varSplit2(intK)) + 1
Next
Pos24 = Pos23 + Len(varSplit2(iWort2))
Pos13 = Pos11
For intK = 0 To iWort - 1
Pos13 = Pos13 + Len(varSplit1(intK)) + 1
Next
Pos14 = Pos13 + Len(varSplit1(iWort))
'Text 1 Markierung entfernen
Call prcMarkierenTextNo(Zelle:=.Cells(Zeile, 3), Pos1:=Pos13, Pos2:=Pos14)
'Text 2 Markierung entfernen
Call prcMarkierenTextNo(Zelle:=.Cells(Zeile + 1, 3), Pos1:=Pos23, Pos2:=Pos24) _
Exit For
End If
Next iWort22
Next iWort
End If
End If
Zeile = Zeile + 1
Else
'Code nur 1 mal vorhanden - Code wird farblich hervorgehoben
With .Cells(Zeile, 2)
If .Offset(0, -1).Value = "+" Then
With .Font
.Bold = True
.Color = FarbePlus
End With
Else
With .Font
.Bold = True
.Color = FarbeMinus
End With
End If
End With
End If
Next
End With 'wksData
Application.ScreenUpdating = True
End Sub