如果匹配项突出显示值 VBA，则识别单词

样本数据：

Code:

Sub HighlightMatchingWords()
    Dim lastRowSheet1 As Long
    Dim lastRowSheet2 As Long
    Dim i As Long
    Dim j As Long
    Dim cellValueSheet1 As String
    Dim cellValueSheet2 As String
    Dim wordsSheet1 As Variant
    Dim wordsSheet2 As Variant
    Dim wordIndexSheet1 As Long
    Dim wordIndexSheet2 As Long
    Dim wordSheet1 As String
    Dim wordSheet2 As String
    
    ' Get the last row of data in column A for Sheet1
    lastRowSheet1 = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 1).End(xlUp).Row
    
    ' Get the last row of data in column A for Sheet2
    lastRowSheet2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row
    
    ' Loop through each row of data in column A for Sheet1
    For i = 1 To lastRowSheet1
        ' Get the value in column A for the current row in Sheet1
        cellValueSheet1 = Sheets("Sheet1").Cells(i, 1).Value
    
        ' Split the string into words for Sheet1
        wordsSheet1 = Split(cellValueSheet1, " ")
    
        ' Loop through each row of data in column A for Sheet2
        For j = 1 To lastRowSheet2
            ' Get the value in column A for the current row in Sheet2
            cellValueSheet2 = Sheets("Sheet2").Cells(j, 1).Value
    
            ' Split the string into words for Sheet2
            wordsSheet2 = Split(cellValueSheet2, " ")
    
            ' Loop through each word in Sheet1
            For wordIndexSheet1 = 0 To UBound(wordsSheet1)
                ' Loop through each word in Sheet2
                For wordIndexSheet2 = 0 To UBound(wordsSheet2)
                    ' If the words match, highlight the word in Sheet1
                    If StrComp(wordsSheet1(wordIndexSheet1), wordsSheet2(wordIndexSheet2), vbTextCompare) = 0 Then
                        wordSheet1 = wordsSheet1(wordIndexSheet1)
                        ' Highlight the word in Sheet1
                        Sheets("Sheet1").Cells(i, 1).Characters(InStr(cellValueSheet1, wordSheet1), Len(wordSheet1)).Font.ColorIndex = 3 ' Highlight in red
                        Sheets("Sheet1").Cells(i, 2).Value = Sheets("Sheet1").Cells(i, 2).Value & " " & word
                    End If
                Next wordIndexSheet2
            Next wordIndexSheet1
        Next j
    Next i
End Sub

我试过了，但没有达到 100% 的准确率，有人可以帮忙吗？

这是实现此目的的一种方法.Find。我已经对代码进行了注释，因此您理解它应该不会有问题。如果您这样做，只需询问即可。

Code:

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim rng As Range
    Dim aCell As Range, bCell As Range
    Dim InputAr As Variant
    Dim i As Long     
    
    '~~> Set this to the relevant sheet
    Set ws = Sheet1
    
    '~~> This is the range where the text nees to be colored
    Set rng = ws.Range("A1:A6")
    
    '~~> This is the range where you have the keywords
    InputAr = ws.Range("D1:D5")
    
    '~~> Loop through the seach keywords
    For i = LBound(InputAr) To UBound(InputAr)
        '~~> Find the text
        Set aCell = rng.Find(What:=InputAr(i, 1), LookIn:=xlFormulas, LookAt:=xlPart)
        
        '~~> If found
        If Not aCell Is Nothing Then
            Set bCell = aCell
            
            '~~> Color the text
            ColorText aCell, InputAr(i, 1)
            
            '~~> Find the next occurance
            Do
                Set aCell = rng.FindNext(After:=aCell)
                
                If Not aCell Is Nothing Then
                    If aCell = bCell Then Exit Do
                    ColorText aCell, InputAr(i, 1)
                End If
            Loop
            
            '~~> Set the found range to Nothing
            Set aCell = Nothing
        End If
    Next i
End Sub

'~~> Proc to color the text
Private Sub ColorText(r As Range, keyword As Variant)
    Dim sPos As Long
    Dim TxtLen As Long
    
    '~~> Set the starting position
    sPos = InStr(1, r.Value2, keyword, vbTextCompare)
    '~~> Get the length
    TxtLen = Len(keyword)
    '~~> Color the text
    r.Characters(Start:=sPos, Length:=TxtLen).Font.Color = RGB(255, 0, 0)
End Sub

截屏：