Найти строку, изменить цвет на всех листах Excel

Question

поиск во всей книге Excel текстовой строки и выделение ячейки , кажется, именно то, что мне нужно, но я не могу заставить его работать с моей книгой Excel. У меня есть сотни строк на 10 листах. Все искомые строки (пакет 01, пакет 02, пакет 03 и т. Д. c) будут находиться в 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)")

(Настроено поэтому я могу ввести до 5 чисел FindStrings и 5 чисел ColorIndex как Dim с InputBox (es)) В 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» и все равно сопоставить.

Мне нравится разделять функцию «найти все» в отдельную функцию: это облегчает отслеживание остальной части логи c.

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