Как сравнить два столбца в Excel, чтобы выделить слова, которые не совпадают?

Question

(Я использую Microsoft Excel 2010)

Допустим, у меня есть список фраз в столбце A и столбце B (см. Снимок экрана ниже)

Я хотел бы, чтобы это было с макросом, VBA или формулой:

Если в какой-либо ячейке столбца A есть слово, которого нет ни в одном из слов столбца B, выделите его красным цветом.

Например: в ячейке A9 есть слово "покупка", но слово "покупка" нигде не упоминается в столбце "Б", поэтому я бы хотел, чтобы слово "покупка" было выделено красным цветом.

Как я могу сделать это?

(Я думаю, что макро /vba будет лучшим вариантом, но я не знаю, как его создать, или даже если это возможно.)

Answer 1

Вставьте следующий код в модуль VBA.

Sub highlightWords()
Application.ScreenUpdating = False
Dim rng2HL As Range, rngCheck As Range, dictWords As Object
Dim a() As Variant, b() As Variant, wordlist As Variant, wordStart As Long
Set r = Selection
'Change the addresses below to match your data.
Set rng2HL = Range("A1:A9")
Set rngCheck = Range("B1:B9")
a = rng2HL.Value
b = rngCheck.Value
Set dictWords = CreateObject("Scripting.Dictionary")
'Load unique words from second column into a dictionary for easy checking
For i = LBound(b, 1) To UBound(b, 1)
    wordlist = Split(b(i, 1), " ")
    For j = LBound(wordlist) To UBound(wordlist)
        If Not dictWords.Exists(wordlist(j)) Then
            dictWords.Add wordlist(j), wordlist(j)
        End If
    Next j
Next i
'Reset range to highlight to all black font.
rng2HL.Font.ColorIndex = 1
'Check words one by one against dictionary.
For i = LBound(a, 1) To UBound(a, 1)
    wordlist = Split(a(i, 1), " ")
    For j = LBound(wordlist) To UBound(wordlist)
        If Not dictWords.Exists(wordlist(j)) Then
            wordStart = InStr(a(i, 1), wordlist(j))
            'Change font color of word to red.
            rng2HL.Cells(i).Characters(wordStart, Len(wordlist(j))).Font.ColorIndex = 3
        End If
    Next j
Next i
Application.ScreenUpdating = True
End Sub

Просто не забудьте изменить адреса в строках ниже, чтобы они соответствовали вашему рабочему листу.

Set rng2HL = Range("A1:A9")
Set rngCheck = Range("B1:B9")

Результаты:

РЕДАКТИРОВАТЬ:

Поскольку вы добавили требования в комментариях ниже, я изменил код, чтобы также распечатать список выделенных красным цветом фраз в столбце C. Если вы хотите этот список в другом месте, вам придется настроить адрес в последнем разделе кода , Я также улучшил код подсветки - я заметил, что он будет делать странные вещи, такие как выделение только первого экземпляра несоответствующего слова.

Sub highlightWords()
Application.ScreenUpdating = False
Dim rng2HL As Range, rngCheck As Range, dictWords As Object, dictRed As Object
Dim a() As Variant, b() As Variant, wordlist As Variant, wordStart As Long, phraseLen As Integer
Dim re As Object, consec As Integer, tmpPhrase As String
'Change the addresses below to match your data.
Set rng2HL = Range("A1:A9")
Set rngCheck = Range("B1:B9")
a = rng2HL.Value
b = rngCheck.Value
Set dictWords = CreateObject("Scripting.Dictionary")
'Load unique words from second column into a dictionary for easy checking
For i = LBound(b, 1) To UBound(b, 1)
    wordlist = Split(b(i, 1), " ")
    For j = LBound(wordlist) To UBound(wordlist)
        If Not dictWords.Exists(wordlist(j)) Then
            dictWords.Add wordlist(j), wordlist(j)
        End If
    Next j
Next i
Erase b
'Reset range to highlight to all black font.
rng2HL.Font.ColorIndex = 1
Set dictRed = CreateObject("Scripting.Dictionary")
Set re = CreateObject("vbscript.regexp")
'Check words one by one against dictionary.
For i = LBound(a, 1) To UBound(a, 1)
    wordlist = Split(a(i, 1), " ")
    consec = 0
    tmpPhrase = ""
    For j = LBound(wordlist) To UBound(wordlist)
        If Not dictWords.Exists(wordlist(j)) Then
            consec = consec + 1
            If consec > 1 Then tmpPhrase = tmpPhrase & " "
            tmpPhrase = tmpPhrase & wordlist(j)
        Else
            If consec > 0 Then
                If Not dictRed.Exists(tmpPhrase) Then dictRed.Add tmpPhrase, tmpPhrase
                re.Pattern = "(^| )" & tmpPhrase & "( |$)"
                Set matches = re.Execute(a(i, 1))
                For Each m In matches
                    wordStart = m.FirstIndex
                    phraseLen = m.Length
                    'Change font color of word to red.
                    rng2HL.Cells(i).Characters(wordStart + 1, phraseLen).Font.ColorIndex = 3
                Next m
                consec = 0
                tmpPhrase = ""
            End If
        End If
    Next j
    'Highlight any matches that appear at the end of the line
    If consec > 0 Then
        If Not dictRed.Exists(tmpPhrase) Then dictRed.Add tmpPhrase, tmpPhrase
        re.Pattern = "(^" & tmpPhrase & "| " & tmpPhrase & ")( |$)"
        Set matches = re.Execute(a(i, 1))
        For Each m In matches
            wordStart = m.FirstIndex
            phraseLen = m.Length
            'Change font color of word to red.
            rng2HL.Cells(i).Characters(wordStart + 1, phraseLen).Font.ColorIndex = 3
        Next m
    End If
Next i
Erase a
'Output list of unique red phrases to column C.
redkeys = dictRed.Keys
For k = LBound(redkeys) To UBound(redkeys)
    Range("C1").Offset(k, 0).Value = redkeys(k)
Next k
Erase redkeys
Application.ScreenUpdating = True
End Sub

Answer 2

Если вы поместите A и B на отдельные листы, вы можете использовать Text to Columns для разделения каждого элемента на несколько ячеек, по одному слову на ячейку. Тогда простой LOOKUP() позволит вам найти слова, которые не отображаются в другом наборе ячеек.