Требуется предложение или помощь для изменения макроса, который может искать подстроку и форматировать после поиска по шаблону для VBA

Question

У меня вопрос к вам всем замечательным людям, которые являются экспертами в VBA.Я нашел этот супер крутой макрос, который окрашивает текст, который предоставляется через поле ввода.Тем не менее, я попытался внести небольшую модификацию, я пытаюсь использовать подстановочный знак "*", например, если я предоставляю VBA*, при вводе строку от "VBA" до конца текста в выбранном диапазонедолжен быть отформатирован.Кодированный формат подстрочного кода vba.Ни один из них не был найден, поэтому я изменил этот код, надеясь, что кто-то из вас может добавить немного магии в мгновение ока.

Это код, который я нашел в поиске:

Sub X_FormatSubStrings()
    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:", "Enter the string", "")
    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
                xCell.Characters(Len(xStrTmp) + 1, xHStrLen).Font.Bold = 3
                xStrTmp = xStrTmp & xHStr
            Next
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

Answer 1

Хотя вопрос не ясен и в коде есть несколько проблем, я предположил, что он применим к Excel и будет работать только с * как подстановочный знак.Код пытаются изменить для предполагаемого использования по назначению.

Sub X_FormatSubStrings()
Dim xHStr As String, CellStr As String
Dim xStrTmp As String, xHStrLen As Long
Dim xCount As Long, i As Long, StPos As Long, EndPos As Long, Pos As Long
Dim xCell As Range
Dim xArr

xHStr = InputBox("What is the string to highlight:", "Enter the string", "*asd*rt*ss*")
If TypeName(xHStr) <> "String" Then Exit Sub
If Len(xHStr) = 0 Then Exit Sub
xArr = Split(xHStr, "*")

    For Each xCell In Selection
    CellStr = xCell.Value
    StPos = 0
    EndPos = 0


            For i = LBound(xArr) To UBound(xArr)
            Pos = InStr(1, CellStr, xArr(i))
            If Pos <= 0 Then Exit For
            If i = LBound(xArr) Then StPos = Pos
            If i = UBound(xArr) Then EndPos = Pos + Len(xArr(i)) - 1
            If i = UBound(xArr) And xArr(i) = "" Then EndPos = Len(CellStr)
            Next i

            If StPos > 0 And EndPos >= StPos Then
            xCell.Characters(StPos, EndPos - StPos + 1).Font.ColorIndex = 3
            xCell.Characters(StPos, EndPos - StPos + 1).Font.Bold = True
            End If

    Next xCell
    MsgBox "Done"

End Sub