我使用 Find function 在 vba Excel 中查找單詞

Question

大家早上好，我正在創建一個 excel 宏來查找單詞並標記單詞和單元格。 我想在我的數組中找到我的單詞。 我遇到的問題是它標記了它找到的所有單詞，即使它包含在另一個單詞中。 例如：我有skin這個詞，它標記了“A skin g”這個詞，所以它標記了Asking這個詞中的skin這個詞，我只想標記“skin”這個詞。 我有辦法改變這個嗎？

在這里，我有我的代碼。

 Dim med_Arr As Integer
    Dim ws As Worksheet
    Dim oRange As Range
    Dim wordToFind As String
    Dim Lista As Variant
    Dim cellRange As Range
    Dim Foundat As String
    
 
    
    
    For Each ws In ActiveWorkbook.Worksheets ' for
        Set oRange = ws.Range("M:M")
        ws.Activate
        Lista = Array("BRAKE", "OIL", "FALL", "CUT", _
        "EXPOSED", "COPPER", "TREND", "NO ALARM", _
        "NOT ALARM", "ALARM IN", "SORE", "BURN", _
        "SPARK", "FLUID", "PAIN", "BLOOD", "MOULD", _
        "HURT", "ITSELF", "SEVERED", "BLISTER", _
        "SELF RUN", "STAY UP", "SKIN", "STAYING UP", _
        "BUZZER", "HEAT", "LATCH", "SPLIT", "VOICE", _
        "FIRE", "SMOKE", "HOT", "FRAY", "VOLUME", _
        "BED EXIT", "COLLAPSE", "WARNING", "LABEL", _
        "HEART MO", "HHR", "RESPIRATORY MONITOR", _
        "COMMUNICATING", "HR NO", "10 C0", "CONTAMINATION", _
        "INGRESS", "EGRESS", "SAFETY", "INJURED", "DIED", _
        "FELL", "WARM", "TILT", "TIPP", "UNSTABLE", "ARC", _
        "VITAL SIGN", "SHOCK", "FLICKER", "ELECTROCUTED", _
        "SHARP", "SLICE", "LACERAT", "ELECTROMAG", "FLAM", _
        "IN HALF", "MUTILA", "EARLYSENSE", "EARLY SENSE", _
        "ENTRAP", "DROP")
        
        med_Arr = UBound(Lista) - LBound(Lista) 'LBound (0)
        For i = 0 To med_Arr 'for loop From 0 to Array Length
            wordToFind = Lista(i) 'saves word to find
            Set cellRange = oRange.Find(What:=wordToFind, LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False, SearchFormat:=False) ' Finds first cell that contains at least one word and sets it to cell range
            If Not cellRange Is Nothing Then ' cell range exists then
                Foundat = cellRange.Address ' variable that contains address of cell that contains the word
                Do ' create variable textStart and set it to 1
                    Dim textStart As Integer
                    textStart = 1
                    Do
                        textStart = InStr(textStart, cellRange.Value, wordToFind) ' set position of current word found to textStart
                        If textStart <> 0 Then ' if textStart different than zero, then it didn't find anything
                            cellRange.Characters(textStart, Len(wordToFind)).Font.Color = RGB(250, 0, 0) ' font Color-red
                            cellRange.Characters(textStart, Len(wordToFind)).Font.Bold = True 'bold
                            cellRange.Interior.ColorIndex = 40 'background color to 40
                            textStart = textStart + 1 ' increase one to textStart (position)  to check if there's more words to look for in the rest of the paragraph
                        End If
                    Loop Until textStart = 0 ' loop again
                    Set cellRange = oRange.FindNext(After:=cellRange) ' set cellRange and find if there's another word in the rest of the paragraph
                Loop Until cellRange Is Nothing Or cellRange.Address = Foundat ' loop until cellRange is empty or the cellRange adress is equal to the current cell
            End If
        Next i
    Next

感謝您的時間和幫助。

Answer 1

這是使用 VBsript 正則表達式 object 的方法：

Option Explicit

Sub RunHighlights()
    Dim ws As Worksheet, c As Range
    'loop over worksheets
    For Each ws In ActiveWorkbook.Worksheets ' for
        For Each c In ws.Range("M1", ws.Cells(Rows.Count, "M").End(xlUp)).Cells
            If Len(c.Value) > 0 Then
                'highlight cell if any matches
                c.Interior.ColorIndex = IIf(HighlightWords(c) > 0, 40, xlNone)
            End If
        Next c
    Next ws
End Sub

'Highlight all words in a cell matching anything in WordList, 
'   and return number of matches
Function HighlightWords(c As Range) As Long
    Dim re As Object, txt As String, matches As Object, m, rv As Long
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\b(" & Join(WordList(), "|") & ")\b" 'join word array to create pattern
                                                       '  \b = word boundary
    re.ignorecase = True
    re.MultiLine = True
    re.Global = True 'match whole text
    
    c.Font.Color = vbBlack 'reset any existing coloring
    Set matches = re.Execute(c.Value)
    For Each m In matches 'loop each match and apply font color
        Debug.Print c.Parent.Name, c.Address, m, m.firstindex, m.Length
        c.Characters(m.firstindex + 1, m.Length).Font.Color = vbRed
        rv = rv + 1
    Next m
    HighlightWords = rv 'return # of matches
End Function

'just returns an array of words to match on
Function WordList()
    WordList = Array("BRAKE", "OIL", "FALL", "CUT", _
        "EXPOSED", "COPPER", "TREND", "NO ALARM", _
        "NOT ALARM", "ALARM IN", "SORE", "BURN", _
        "SPARK", "FLUID", "PAIN", "BLOOD", "MOULD", _
        "HURT", "ITSELF", "SEVERED", "BLISTER", _
        "SELF RUN", "STAY UP", "SKIN", "STAYING UP", _
        "BUZZER", "HEAT", "LATCH", "SPLIT", "VOICE", _
        "FIRE", "SMOKE", "HOT", "FRAY", "VOLUME", _
        "BED EXIT", "COLLAPSE", "WARNING", "LABEL", _
        "HEART MO", "HHR", "RESPIRATORY MONITOR", _
        "COMMUNICATING", "HR NO", "10 C0", "CONTAMINATION", _
        "INGRESS", "EGRESS", "SAFETY", "INJURED", "DIED", _
        "FELL", "WARM", "TILT", "TIPP", "UNSTABLE", "ARC", _
        "VITAL SIGN", "SHOCK", "FLICKER", "ELECTROCUTED", _
        "SHARP", "SLICE", "LACERAT", "ELECTROMAG", "FLAM", _
        "IN HALF", "MUTILA", "EARLYSENSE", "EARLY SENSE", _
        "ENTRAP", "DROP")
End Function