突出顯示搜索Word中的VBA

Question

我想要一個代碼，將突出顯示搜索的每個單詞。我已經有了一個代碼，除了第30行之後，它開始突出顯示所有內容。爲了清晰起見，我會添加圖片。我不知道我的代碼有什麼問題，或者我可以修復哪些問題。

這裏是我的代碼。

Sub Highlight() 
Application.ScreenUpdating = False 
Dim Rng As Range 
Dim cFnd As String 
Dim xTmp As String 
Dim x As Long 
Dim m As Long 
Dim y As Long 
cFnd = ComboBox1.Value 
y = Len(cFnd) 
For Each Rng In Selection 
    With Rng 
    m = UBound(Split(Rng.Value, cFnd)) 
    If m > 0 Then 
     xTmp = "" 
     For x = 0 To m - 1 
     xTmp = xTmp & Split(Rng.Value, cFnd)(x) 
     .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3 
     xTmp = xTmp & cFnd 
     Next 
    End If 
    End With 
Next Rng 
Application.ScreenUpdating = True 
End Sub 

這是將搜索結果帶到圖片中顯示的頁面的搜索代碼。

Sub FindOne() 

Range("B19:J5000") = "" 

Application.ScreenUpdating = False 

Dim k As Integer, EndPasteLoopa As Integer, searchColumn As Integer, searchAllCount As Integer 
Dim myText As String 
Dim totalValues As Long 
Dim nextCell As Range 
Dim searchAllCheck As Boolean 

k = ThisWorkbook.Worksheets.Count 
myText = ComboBox1.Value 
Set nextCell = Range("B20") 
If myText = "" Then 
    MsgBox "No Address Found" 
    Exit Sub 
End If 

Select Case ComboBox2.Value 
    Case "SEARCH ALL" 
     searchAllCheck = True 
    Case "EQUIPMENT NUMBER" 
     searchColumn = 1 
    Case "EQUIPMENT DESCRIPTION" 
     searchColumn = 3 
    Case "DUPONT NUMBER" 
     searchColumn = 6 
    Case "SAP NUMBER" 
     searchColumn = 7 
    Case "SSI NUMBER" 
     searchColumn = 8 
    Case "PART DESCRIPTION" 
     searchColumn = 9 
    Case "" 
     MsgBox "Please select a value for what you are searching by." 
End Select 

For I = 2 To k 
    totalValues = Sheets(I).Cells(Rows.Count, "A").End(xlUp).Row 
    ReDim AddressArray(totalValues) As String 

    If searchAllCheck Then 
     searchAllCount = 5 
     searchColumn = 1 
    Else 
     searchAllCount = 0 
    End If 

    For qwerty = 0 To searchAllCount 
     If searchAllCount Then 
      Select Case qwerty 
       Case "1" 
        searchColumn = 3 
       Case "2" 
        searchColumn = 6 
       Case "3" 
        searchColumn = 7 
       Case "4" 
        searchColumn = 8 
       Case "5" 
        searchColumn = 9 
      End Select 
     End If 

     For j = 0 To totalValues 
      AddressArray(j) = Sheets(I).Cells(j + 1, searchColumn).Value 
     Next j 

      For j = 0 To totalValues 
      If InStr(1, AddressArray(j), myText) > 0 Then 
       EndPasteLoop = 1 
       If (Sheets(I).Cells(j + 2, searchColumn).Value = "") Then EndPasteLoop = Sheets(I).Cells(j + 1, searchColumn).End(xlDown).Row - j - 1 
       For r = 1 To EndPasteLoop 
        Range(nextCell, nextCell.Offset(0, 8)).Value = Sheets(I).Range("A" & j + r, "I" & j + r).Value 
        Set nextCell = nextCell.Offset(1, 0) 
       Next r 
      End If 
     Next j 
    Next qwerty 
Next 
Application.ScreenUpdating = True 
Range("A1").Select 
End Sub 

謝謝！

Answer 1

這裏是一個辦法，做你想做的事，但在一定程度上更直接的方式：

Sub HighlightCell(Rng As Range, cFnd As String) 
    'highlights all nonoverlapping occurrences of cFnd in Rng (which is assumed to be a single cell) 
    Dim s As String 
    Dim i As Long, y As Long 
    y = Len(cFnd) 
    s = Rng.Value 
    With Rng 
     i = InStr(1, s, cFnd) 
     Do While i > 0 
      .Characters(Start:=i, Length:=y).Font.ColorIndex = 3 
      i = InStr(i + y + 1, s, cFnd) 
     Loop 
    End With 
End Sub 

Sub Highlight() 
    Application.ScreenUpdating = False 
    Dim Rng As Range 
    Dim cFnd As String 

    cFnd = InputBox("Search for?") 'so I could test without setting up the combobox 
    For Each Rng In Selection 
     HighlightCell Rng, cFnd 
    Next Rng 
    Application.ScreenUpdating = True 
End Sub 

下面的截圖顯示運行時A1:B2代碼的結果來選擇，其中搜索項是cat。請注意，它是區分sensitve：

究竟爲什麼你的個子是在演戲會是這樣，我不知道。毫無疑問，它與你在尋找的字符串上分裂的方式有關，而不是直接找到它。

您可以使用Find method來更有效地查找相關單元，但上面的代碼應該修復您遇到的錯誤。

Answer 2

嗯，我真的很愚蠢。我最初的工作。我在其他專欄中填寫奇怪的原因是因爲我不會在每次執行新搜索時清除文本格式。當我改變它時，它修復了一切。