Пометить ячейки жирным шрифтом соответствующими частичными

Question

У меня есть код, который еще не работает. Предполагается открыть окно ввода, где вы можете ввести текст. Затем должно открыться окно, где вы можете ввести диапазон. После обеих записей должен быть произведен поиск всей рабочей книги, а вся ячейка, в которой находится частичный текст, должна быть выделена жирным шрифтом. Если ячейка содержит больше текста, чем искомая, она должна быть помечена жирным шрифтом. Например, в ячейке есть текст: «Область экспорта Азии»

Если я только введу «Область экспорта» в окне ввода, ячейка, содержащая «Область экспорта Азии», должна быть помечена полностью жирным шрифтом.

Вот мой код:

Sub Zelle_Fett_Wenn_best_Inhalt_Input_Box()
Dim Filtertext As String
Dim ws As Worksheet
Dim aRange As Range
On Error Resume Next
  Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
  If aRange Is Nothing Then
    MsgBox "Operation Cancelled"
  Else
    aRange.Select
  End If

Filtertext = InputBox("Enter Text")
For Each ws In Worksheets
ws.Select
x = ActiveSheet.UsedRange.Rows.Count
Rows.Select
If Cells.Value Like Filtertext Then
    Selection.Font.Bold = True
Else
    Selection.Font.Bold = False
End If
Next ws
End Sub

Может быть, кто-то был бы так рад исправить его, чтобы он работал.

Большое спасибо и ура Том

Answer 1

Так что согласно моему комментарию, я бы посоветовал не использовать .Select или UsedRange. Вместо этого динамически получайте последние использованные строки и столбцы. Кроме того, в вашем операторе Like отсутствуют символы подстановки, и вы захотите перебирать весь объект Range.

Далее я бы сказал, что вы можете пропустить итерацию и использовать условное форматирование ИЛИ использовать ReplaceFormat, например:

Sub Test()

Dim lr As Long, lc As Long, rng As Range, ws As Worksheet, FilterText As String

FilterText = InputBox("Enter Text")
If FilterText = "" Then Exit Sub

For Each ws In ThisWorkbook.Worksheets

    'Get last used row and column
    lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    'Set your range object
    Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc))

    'Set your ReplaceFormat
    With Application.ReplaceFormat
        .Clear
        .Font.Bold = True
    End With

    'Replace formatting to cells with right criteria
    rng.Font.Bold = False
    rng.Replace What:="*" & FilterText & "*", Replacement:="", SearchFormat:=False, ReplaceFormat:=True

Next ws

End Sub

Я пропустил aRange, так как не заметил, что вы никогда даже использовать его.