突出显示在VBA中searchWord

我想要一个代码来突出显示search到的每个单词。 我已经有了一个代码，除了第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 

这是将search结果带到图片中显示的页面的search代码。

 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 

以下屏幕截图显示了在selectA1:B2情况下运行代码的结果，其中search项是cat 。 请注意，这是敏感的：

确切地说，为什么你的小组以这种方式行事，我不知道。 毫无疑问，它与你在寻找的string上分裂的方式有关，而不是直接find它。

你可以看看使用Find方法来更有效地定位相关的单元格，但是上面的代码应该可以解决你遇到的错误。

Answer 2

那么我真的很愚蠢。 我最初的工作 我奇怪的填充其他列的原因是因为我没有清除文本格式，每当我会做一个新的search。 当我改变了，它修复了一切。