查找字符串，更改所有 Excel 工作表的颜色

Question

search entire Excel workbook for text string and highlight cell 似乎正是我所需要的，但我无法让它在我的 Excel 工作簿上工作。我在 10 个工作表中有数百行。所有搜索到的字符串（数据包 01、数据包 02、数据包 03 等）将位于 B:8 到 worksheet(1) 的行端和 B:7 到其他 9 的行端工作表（工作表被命名并且字符串的InputBox 结果需要区分大小写）。 45547221 表示内部颜色变化，但是所有字符串都有不同颜色的单元格时颜色会太多，因此使用font.color.index 更改字符串颜色会更好。按原样尝试 45547221 代码会发现它在步进模式下跳过了 Do/Loop While 代码。

我会修改 45547221 中的代码，至少添加：

Dim myColor As Integer
myColor = InputBox("Enter Color Number (1-56)")

（配置后我可以使用 InputBox(es) 输入多达 5 个 FindStrings 和 5 个 ColorIndex 数字作为 Dim） 在Do/Loop While 我会更改.ColorIndex = myColor

我想让这段代码工作，因为它似乎符合我的需要 - 修改为在工作簿中查找字符串实例并重新着色字符串而不是单元格内部颜色，以及 (2) 让它识别 Do/Loop While 代码现在不是，但会将ColorIndex 数字应用于每个字符串。

---

Public Sub find_highlight()

    'Put Option Explicit at the top of the module and
    'Declare your variables.
    Dim FindString As String
    Dim wrkSht As Worksheet
    Dim FoundCell As Range
    Dim FirstAddress As String
    Dim MyColor As Integer 'Added this

    FindString = InputBox("Enter Search Word or Phrase")
    MyColor = InputBox("Enter Color Number")

    'Use For...Each to cycle through the Worksheets collection.
    For Each wrkSht In ThisWorkbook.Worksheets
        'Find the first instance on the sheet.
        Set FoundCell = wrkSht.Cells.Find( _
            What:=FindString, _
            After:=wrkSht.Range("B1"), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
        'Check it found something.
        If Not FoundCell Is Nothing Then
            'Save the first address as FIND loops around to the start
            'when it can't find any more.
            FirstAddress = FoundCell.Address
            Do
                With FoundCell.Font 'Changed this from Interior to Font
                    .ColorIndex = MyColor
                    '.Pattern = xlSolid
                    '.PatternColorIndex = xlAutomatic 'Deactivated this
                End With
                'Look for the next instance on the same sheet.
                Set FoundCell = wrkSht.Cells.FindNext(FoundCell)
            Loop While FoundCell.Address <> FirstAddress
        End If

    Next wrkSht

End Sub

Answer 1

编辑：这对您的示例数据有用，使用部分匹配，因此您可以输入（例如）“数据包 03”并且仍然匹配。

我喜欢将“查找所有”功能拆分为一个单独的功能：它使其余的逻辑更容易理解。

Public Sub FindAndHighlight()

    Dim FindString As String
    Dim wrkSht As Worksheet
    Dim FoundCells As Range, FoundCell As Range
    Dim MyColor As Integer 'Added this
    Dim rngSearch As Range, i As Long, rw As Long

    FindString = InputBox("Enter Search Word or Phrase")
    MyColor = InputBox("Enter Color Number")

    'Cycle through the Worksheets
    For i = 1 To ThisWorkbook.Worksheets.Count

        Set wrkSht = ThisWorkbook.Worksheets(i)

        rw = IIf(i = 1, 8, 7) '<<< Row to search on
                              '    row 8 for sheet 1, then 7

        'set the range to search
        Set rngSearch = wrkSht.Range(wrkSht.Cells(rw, "B"), _
                        wrkSht.Cells(Rows.Count, "B").End(xlUp))

        Set FoundCells = FindAll(rngSearch, FindString) '<< find all matches

        If Not FoundCells Is Nothing Then
            'got at least one match, cycle though and color
            For Each FoundCell In FoundCells.Cells
                FoundCell.Font.ColorIndex = CInt(MyColor)
            Next FoundCell
        End If

    Next i

End Sub

'return a range containing all matching cells from rng
Public Function FindAll(rng As Range, val As String) As Range
    Dim rv As Range, f As Range
    Dim addr As String

    'partial match...
    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True) 'case-sensitive
    If Not f Is Nothing Then addr = f.Address()

    Do Until f Is Nothing
        If rv Is Nothing Then
            Set rv = f
        Else
            Set rv = Application.Union(rv, f)
        End If
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop

    Set FindAll = rv
End Function