Изменение нескольких текстовых строк с помощью Excel VBA

Question

Я использую модифицированный макрос VBA, который я нашел на exteoffice.com, чтобы изменить входные указанные строки в ячейках.Макрос работает отлично;Я выделяю ячейки, которые хочу проанализировать, и он запрашивает ввод.Затем указанная строка окрашивается в синий цвет и выделяется жирным шрифтом.Я надеюсь, что смогу немного изменить это, чтобы макрос мог находить несколько строк без необходимости запуска отдельно для каждой новой строки.

Пробовал: для i для UserList // UserList = ячейка A1 со строками, разделенными запятыми

Sub HighlightStrings()
'Updateby Extendoffice 20160704
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 = InputBox("Enter the text string to highlight")
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
        .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.Bold = True
        xTmp = xTmp & cFnd
      Next
    End If
  End With
Next Rng
Application.ScreenUpdating = True
End Sub

Я хочу выделить жирным шрифтом и синего цвета слова «тромб», «инсульт»,«антикоагулянтная терапия»;для этого макрос нужно запустить три раза.Я хотел бы иметь возможность составить список строк и позволить макросу проходить по списку, поэтому мне нужно запустить его только один раз.

У меня очень мало знаний в области кодирования, и я благодарю вас за вашу помощь.

Answer 1

Мы можем внести незначительные изменения в ваш саб, чтобы он мог принять аргумент и затем вызвать его в цикле:

Sub MAIN()
    Dim MyList As String, arr, a
    MyList = Application.InputBox(Prompt:="give me comma-separated text strings", Type:=2)
    arr = Split(MyList, ",")
    For Each a In arr
        Call HighlightStrings(a)
    Next a
End Sub

Sub HighlightStrings(cFnd As Variant)
        'Updateby Extendoffice 20160704
        Application.ScreenUpdating = False
        Dim Rng As Range
        Dim xTmp As String
        Dim x As Long
        Dim m As Long
        Dim y As Long

        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
                .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.Bold = True
                xTmp = xTmp & cFnd
              Next
            End If
          End With
        Next Rng
        Application.ScreenUpdating = True
End Sub

Answer 2

Вы можете создать коллекцию и пройти через нее. Извините, это немного беспорядок, но я сейчас немного занят и не могу очистить код, как мне хотелось бы, но это работает; Поле ввода будет отображаться, если оно либо оставлено пустым, либо нажата кнопка «Отмена»:

Sub HighlightStrings()
    'Updateby Extendoffice 20160704
    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
    Dim myCol As New Collection

    Do
        ib = InputBox("Enter the text string to highlight")
        If ib <> vbNullString Then myCol.Add ib
    Loop While ib <> vbNullString

    For Each mc In myCol
        cFnd = mc
        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
                        .Characters(Start:=Len(xTmp) + 1, Length:=y).Font.Bold = True
                        xTmp = xTmp & cFnd
                    Next
                End If
            End With
        Next Rng
    Next mc

    Application.ScreenUpdating = True
End Sub