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

Question

Я всегда скрывался за переполнением стека, но я впервые задаю вопрос.

Я составил список ключевых слов, связанных с предметом, который мне нужно изучить, из списка отзывов об опросе. В идеале я хотел бы иметь макрос, который я запускаю, который ссылается на этот список ключевых слов, а затем проходит все опросы и выделяет только ключевые слова. Это обеспечило бы визуальное представление о том, как часто слово или фраза упоминаются.

Я искал ответ и обнаружил, что этот макрос вставлен внизу.

Этот макрос очень помог, но у него есть свои недостатки ...

1. Требуется, чтобы я постоянно запускал макрос, а затем вводил текстовую строку из списка ключевых слов. Очень много времени. Тем более, что чем больше я могу добавить в свой список, тем лучше.
2. С учетом регистра, который потенциально удваивает время, необходимое для запуска всех слов в моем списке ключей, так как мне нужно запустить их с заглавными буквами, чтобы я ничего не пропустил

Кто-нибудь знает, как я могу изменить или этот код можно переписать, чтобы я мог выделить опросы, а затем нацелиться на список слов, и все, что следует выделить, будет?

Спасибо!

'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
        xTmp = xTmp & cFnd
      Next
    End If
  End With
Next Rng
Application.ScreenUpdating = True
End Sub```

Answer 1

Попробуйте этот код

Sub Highlight_Text_Strings()
Dim rng As Range, c As Range, cl As Range, cFnd As String, v As String, xTmp As String, xColor As Long, x As Long, m As Long

Application.ScreenUpdating = False
    Set rng = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
    rng.Font.ColorIndex = 0: xColor = 3

    For Each c In Sheet1.Range("H1:H3")     'Keywords List
        cFnd = UCase(c.Value)
        For Each cl In rng
            v = UCase(cl.Value)
            With cl
                m = UBound(Split(v, cFnd))
                If m > 0 Then
                    xTmp = ""
                    For x = 0 To m - 1
                        xTmp = xTmp & Split(v, cFnd)(x)
                        .Characters(Start:=Len(xTmp) + 1, Length:=Len(cFnd)).Font.ColorIndex = xColor

                        xTmp = xTmp & cFnd
                    Next x
                End If
            End With
        Next cl
        xColor = xColor + 1
    Next c
Application.ScreenUpdating = True
End Sub