在 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。请注意，它区分大小写：

我不知道你的潜艇为什么会这样。毫无疑问，这与您在要搜索的字符串上拆分的方式有关，而不是更直接地找到它。

您可以考虑使用Find method 更有效地定位相关单元格，但上述代码应该可以修复您遇到的错误。

Answer 2

嗯，我觉得自己很笨。我最初的工作。我在其他列中得到奇怪填充的原因是因为每当我进行新搜索时我都没有清除文本格式。当我改变它时，它修复了一切。