Porównaj 2 komórki i zaznacz pasujące słowa

Mam zdanie w kolumnie A i mam zdanie w kolumnie B. Chcę dopasować A1 i B1 i kolor czerwony do pasujących słów. Na przykład:

A1: Lenovo T450 with 5 GB RAM Intel i5 CPU 500 GB HDD 14" HD screen, weight 3.5 pounds (90)

B1: Len 5 GB h i5 CPU 500 GB HDD 14" HD 3.5 (90)

I chcę pokolorować na czerwono poniższe słowa w komórce A1 - 5 GB i5 CPU 500 GB HDD 14" HD 3.5 (90)

W mojej poprzedniej odpowiedzi wystąpił błąd, który przeoczyłem. W rzadkich przypadkach po słowie znajdowała się ta sama litera, na której kończyła się, podczas gdy wyszukiwana była tylko ta litera, wówczas zarówno litera końcowa, jak i następna były kolorowe.

Oto zaktualizowana odpowiedź:

Najpierw piszemy sub i kilka zmiennych, których będziemy potrzebować:

Sub sameStringRed()

Dim i As Integer, j As Integer, intStart As Integer
Dim rngA As Range, rngB As Range
Dim strDelimit As String: strDelimit = " "

Zmienna strDelimit określa, co oddziela słowa od siebie i w razie potrzeby może zostać zmieniona na coś takiego jak „,”.

Następnie kontynuujemy ustawianie naszych zakresów według potrzeb.

For Each rngA In Selection.Rows
    Set rngB = rngA.Offset(0, 1)
    strA = Split(rngA.Text, strDelimit)
    strB = Split(rngB.Text, strDelimit)
 Next

Każdy wybrany wiersz w kolumnie będzie, rngAa każdy wiersz w kolumnie obok niego będzie rngB. Następnie tworzona jest tablica z Splitfunkcją, z jednym wpisem dla każdego słowa w każdej komórce.

Następnie przechodzimy do porównania dwóch tablic:

For j = LBound(strA) To UBound(strA)
    For i = LBound(strB) To UBound(strB)
        If UCase(strA(j)) = UCase(strB(i)) Then
            intStart = InStr(1, strDelimit + UCase(rngA.Value) + strDelimit, strDelimit + UCase(strB(i)) + strDelimit)

        End If
    Next i
Next j

Spowoduje to pobranie każdego wpisu z każdej tablicy i porównanie ich ze sobą. A jeśli są identyczne, zmienna intStartzostanie ustawiona na pozycję pierwszego pasującego słowa w komórce rngA wybranej komórki . Teraz z dodanym strDelimit po obu stronach, aby upewnić się, że nie jest to inne słowo kończące się lub rozpoczynające się od szukanej rzeczy.

Teraz musimy faktycznie coś zrobić z tymi informacjami, więc w poprzednim ifoświadczeniu możemy użyć następujących elementów:

While intStart > 0
    rngA.Characters(Start:=intStart, Length:=Len(strB(i))).Font.ColorIndex = 3
    intStart = InStr(intStart + 1, strDelimit + UCase(rngA.Value) + strDelimit, strDelimit + UCase(strB(i)) + strDelimit)
Wend

Tutaj po prostu ustawiamy kolor znaków w wybranej komórce na indeks 3, który jest czerwony.
Następnie dodajemy +1 do intStart i ponownie sprawdzamy, czy mamy więcej pasujących słów.

Drobny problem to teraz

For Each rngA In Selection.Rows
    Set rngB = rngA.Offset(0, 1)

spowoduje wyświetlenie błędu, jeśli zostanie wybranych wiele kolumn.

Aby sobie z tym poradzić, możemy dodać prostą obsługę błędów przy użyciu On Error GoTo Error

Końcowy kod będzie wyglądał następująco: Edytuj W przypadku pominięcia wielkości liter i ponownie dodano funkcję sterowania.

Sub sameStringRed()

Dim i As Integer, j As Integer, intStart As Integer
Dim rngA As Range, rngB As Range
Dim strDelimit As String: strDelimit = " "

For Each rngA In Selection.Rows
    Set rngB = rngA.Offset(0, 1)
    On Error GoTo Error
    strA = Split(rngA.Text, strDelimit)
    strB = Split(rngB.Text, strDelimit)
    For j = LBound(strA) To UBound(strA)
        For i = LBound(strB) To UBound(strB)
            If UCase(strA(j)) = UCase(strB(i)) Then
                intStart = InStr(1, strDelimit + UCase(rngA.Value) + strDelimit, strDelimit + UCase(strB(i)) + strDelimit)
                While intStart > 0
                    rngA.Characters(Start:=intStart, Length:=Len(strB(i))).Font.ColorIndex = 3
                    intStart = InStr(intStart + 1, strDelimit + UCase(rngA.Value) + strDelimit, strDelimit + UCase(strB(i)) + strDelimit)

                Wend
            End If
        Next i
    Next j
Next
Exit Sub
Error:
MsgBox "Please do not select multiple columns"
End Sub

Wynik powinien wyglądać następująco: