Модификация существующего кода для одновременного выделения нескольких разных слов вместо выделения одной строки

Question

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

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

Sub HighlightStrings()
    Dim xHStr As String, xStrTmp As String
    Dim xHStrLen As Long, xCount As Long, I As Long
    Dim xCell As Range
    Dim xArr
    On Error Resume Next
    xHStr = Application.InputBox("What is the string to highlight:", "KuTools For Excel", , , , , , 2)
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        xHStrLen = Len(xHStr)
        For Each xCell In Selection
            xArr = Split(xCell.Value, xHStr)
            xCount = UBound(xArr)
            If xCount > 0 Then
                xStrTmp = ""
                For I = 0 To xCount - 1
                    xStrTmp = xStrTmp & xArr(I)
                    xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                    xStrTmp = xStrTmp & xHStr
                Next
            End If
        Next
    Application.ScreenUpdating = True
End Sub

Answer 1

Этот измененный код позволит вам ввести несколько слов, разделенных пробелами, и все они будут выделены:

Option Explicit
'v0.1.1
Sub HighlightStrings()
    Dim xHStr As String, xStrTmp As String
    Dim xHStrLen As Long, xCount As Long, I As Long
    Dim xCell As Range
    Dim xArr
    On Error Resume Next
    xHStr = Application.InputBox("What are the words to highlight:", "Word Higlighter")
    If TypeName(xHStr) <> "String" Then Exit Sub
    Application.ScreenUpdating = False
        For Each xCell In Selection
            Dim varWord As Variant
            For Each varWord In Split(xHStr, Space$(1))
                xHStrLen = Len(varWord)
                xArr = Split(xCell.Value, varWord)
                xCount = UBound(xArr)
                If xCount > 0 Then
                    xStrTmp = ""
                    For I = 0 To xCount - 1
                        xStrTmp = xStrTmp & xArr(I)
                        xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.ColorIndex = 3
                        xStrTmp = xStrTmp & varWord
                    Next
                End If
            Next varWord
        Next xCell
    Application.ScreenUpdating = True
End Sub

Он использует функцию Split() для разделения введенных слов в массив, а затем использует дополнительный цикл для циклического перебора всех слов для каждой ячейки в выделении.

Обратите внимание, что код чувствителен к регистру. Это может быть изменено, чтобы стать нечувствительным к регистру, изменяя это утверждение

xArr = Split(xCell.Value, varWord)

к этому

xArr = Split(UCase$(xCell.Value), UCase$(varWord))

Answer 2

Эта измененная версия кода VBA выделит определенные слова в выбранном диапазоне.

Создайте командную кнопку и введите этот код.

Private Sub CommandButton1_Click()

Dim strSearch As String
Dim UserRange As Range
Dim arySearch As Variant
Dim searchRng As Range
Dim cel As Range
Dim i As Long, ii As Long

Set UserRange = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8)

strSearch = InputBox("Please Enter Text To Highlight As A Comma Delimited List (Abc, Xyz) it's Case Sensative :", "Highlight Text")

If strSearch = "" Then Exit Sub
arySearch = Split(strSearch, ",")

For Each cel In UserRange

With cel

For ii = LBound(arySearch) To UBound(arySearch)

i = InStr(cel.Value, arySearch(ii))
If i > 0 Then

.Characters(i, Len(arySearch(ii))).Font.ColorIndex = 3
End If
Next ii
End With
Next cel
End Sub

Как это устроено:

• Нажмите кнопку «Команда».
• Ответьте на первое поле ввода, выбрав диапазон данных, и завершите, нажав ОК.
• Введите слова, разделенные запятой (например, Abc, Xyz), пока появляется второе поле ввода и заканчивается ок.

Обратите внимание, помните, что он чувствителен к регистру, поэтому пишите слова точно так, как написано в ячейках.