Как выделить подстроку с помощью оператора LIKE в Excel VBA

Question

У меня есть строки, которые выглядят так:

DTTGGRKDVVNHCGKKYKDK
RKDVVNHCGKKYKDKSKRAR

Я хочу выделить область жирным и красным шрифтом.В результате:

Я пробовал следующий код, используя оператор LIKE в Excel VBA, но он разрывается в этой строке Set MC = .Execute(C.Text)

Option Explicit
Sub boldSubString()
    Dim R As Range, C As Range
    Dim MC As Object    

    Set R = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))

    For Each C In R
        C.Font.Bold = False
        If C.Text Like "KK*K" Or C.Text Like "KR*R"  Then
            Set MC = .Execute(C.Text)
            C.Characters(MC(0).firstindex + 1, MC(0).Length).Font.Bold = True
        End If
    Next C    

End Sub

Какой правильный способ сделать это?Я использую Mac Excel версии 15.31

Answer 1

Без регулярных выражений вы можете попробовать следующее.Я не тестировал его всесторонне, но, похоже, он работает даже с несколькими совпадающими подстроками в одной строке.

Изучите VBA HELP для используемых функций, чтобы вы поняли, как это работает, а также какдля создания правильных шаблонов, которые будут использоваться с оператором Like, на случай, если вам нужно расширить список возможных шаблонов.

Option Explicit
Sub boldSS()
    Dim WS As Worksheet
    Dim R As Range, C As Range
    Dim sPatterns(1) As String
    Dim I As Long, J As Long

sPatterns(0) = "KR?R"
sPatterns(1) = "KK?K"

Set WS = Worksheets("sheet1")
With WS
    Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

For Each C In R

        'Reset to default
        With C.Font
            .Bold = False
            .Color = vbBlack
        End With

    For I = 0 To UBound(sPatterns)
        If C Like "*" & sPatterns(I) & "*" Then
            For J = 1 To Len(C) - Len(sPatterns(I)) + 1
                If Mid(C, J, Len(sPatterns(I))) Like sPatterns(I) Then
                    With C.Characters(J, Len(sPatterns(I))).Font
                        .Bold = True
                        .Color = vbRed
                    End With
                    If J < Len(C) - 3 Then
                        J = J + 3
                    Else
                        Exit For
                    End If
                End If
            Next J
        End If
    Next I
Next C
End Sub

Используя вместо этого эквивалентный шаблон регулярного выражения для оператора Like, вы можетеперепишите выше, как показано ниже.Обратите внимание, что ваш шаблон Regex также будет соответствовать KKAR и KRAK (как и макрос ниже, но не выше).

Option Explicit
Sub boldSS()
    Dim WS As Worksheet
    Dim R As Range, C As Range
    Dim sPattern As String
    Dim I As Long

sPattern = "K[KR]?[KR]"

Set WS = Worksheets("sheet1")
With WS
    Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

For Each C In R
        With C.Font
            .Bold = False
            .Color = vbBlack
        End With
        If C Like "*" & sPattern & "*" Then
            For I = 1 To Len(C) - 4 + 1
                If Mid(C, I, 4) Like sPattern Then
                    With C.Characters(I, 4).Font
                        .Bold = True
                        .Color = vbRed
                    End With
                    If I < Len(C) - 3 Then
                        I = I + 3
                    Else
                        Exit For
                    End If
                End If
            Next I
        End If
Next C
End Sub

Answer 2

Проблемы с подстрокой могут быть сложными, если их немного сверлить.Например, в примере OP подстрока KKYKDKSK также является правильной подстрокой KK * K , таким образом, она, вероятно, также может иметь цветовую кодировку.

В общем, с некоторыми ограничениями задача, такая как поиск неперекрывающихся подстрок и учитывая, что подстрока присутствует один раз на строку, это возможно:

При некотором жестком кодировании переменных и проверке только на KK * K , вот как выглядит основной метод:

Option Explicit    
Sub TestMe()

    Dim myRange As Range: Set myRange = Worksheets(1).Range("A1:A2")

    Dim myCell As Range
    For Each myCell In myRange
        myCell.Font.Bold = False
        Dim subString As String
        subString = findTheSubString(myCell.Value2, "KK*K")
        Debug.Print myCell.text, subString
        ChangeTheFont subString, myCell, vbBlue
    Next myCell

End Sub

Функция findTheSubString() берет 2 строки и возвращает подстроку, которая будет помечена цветом позже:

Public Function findTheSubString(wholeString As String, subString As String) As String

    Dim regEx           As Object
    Dim inputMatches    As Object
    Dim regExString     As String

    Set regEx = CreateObject("VBScript.RegExp")

    With regEx
        .Pattern = Split(subString, "*")(0) & "[\s\S]*" & Split(subString, "*")(1)
        .IgnoreCase = True
        .Global = True

        Set inputMatches = .Execute(wholeString)
        If regEx.test(wholeString) Then
            findTheSubString = inputMatches(0)
        Else
            findTheSubString = "Not Found!"
        End If

    End With

End Function

Последняя часть заключается в изменении шрифта определенной подстроки в диапазоне Excel, поэтому аргументы являются строкойи диапазон:

Sub ChangeTheFont(lookFor As String, currentRange As Range, myColor As Long)

    Dim startPosition As Long: startPosition = InStr(1, currentRange.Value2, lookFor)
    Dim endPosition As Long: endPosition = startPosition + Len(currentRange.Value2)

    With currentRange.Characters(startPosition, Len(lookFor)).Font
        .Color = myColor
        .Bold = True
    End With
End Sub