Найти текстовую строку внутри текстовой строки и заменить часть исходной текстовой строки красной текстовой строкой из другой ячейки

Question

У меня есть рабочая тетрадь с 2 листами.В ячейке листа 1 листа А1 есть черный текст.На листе 2 есть два столбца, с которыми я работаю: столбец A (столбец поиска) и столбец B (столбец замены).Столбцы листа 2 A (столбец поиска) и B (столбец замены) содержат текстовые строки.Текстовые строки в столбцах листа 2 A (столбец поиска) и B (столбец замены) также черные.

Я пытаюсь найти текстовую строку в ячейке листа 1 A1, проверьте, содержит ли онатекстовую строку из ячейки листа 2 A2 (столбец поиска) и, если это так, замените эту часть текстовой строки в ячейке листа 1 A1 (красная текстовая версия) текстовой строки в ячейке листа 2 B1 (замена)столбец).

Я бы хотел, чтобы макрос проходил по всем используемым строкам в столбце А листа 2, если в ячейке А1 листа 1 содержится текстовая строка из оставшихся использованных строк в столбце А листа 2, снова заменяя эту частьтекстовой строки в ячейке листа 1 A1 с (красная текстовая версия) текстовой строкой в ​​ячейке листа 2 B1 (столбец замены).

Есть лучший способ сказать это.Но, чтобы быть ясным, я не хочу заменять все содержимое ячейки листа 1 A1, просто (красная текстовая версия) текстовая строка из ячейки листа 2 B1.

Часть поиска замены отлично работает,Но я не могу заставить замененные части текстовой строки в ячейке А1 листа 1 стать красными и оставаться красными.

Любая помощь будет принята с благодарностью!

Вот код, который яработаю до сих пор:

Sub FindReplace()

    Dim mySheet As Worksheet
    Dim myReplaceSheet As Worksheet
    Dim myLastRow As Long
    Dim myRow As Long
    Dim myFind As String
    Dim myReplace As String

'   Specify name of  sheet
    Set mySheet = Sheets("Strings")

'   Specify name of Sheet with list of finds

'   Specify name of Sheet with list of finds and replacements
    Set myReplaceSheet = Sheets("Synonyms")

'   Assuming the list of  that need replaced start in column B on row 1, find last entry in list
    myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False

'   Loop through all list of replacments
    For myRow = 1 To myLastRow
'       Get find and replace values (from columns A and B)
        myFind = myReplaceSheet.Cells(myRow, "A")
        myReplace = myReplaceSheet.Cells(myRow, "B")
'       Start at top of data sheet and do replacements
        mySheet.Activate
        Range("B1").Select
'       Ignore errors that result from finding no matches
        On Error Resume Next
'       Do all replacements on column A of data sheet
        ColorReplacement Sheets("Strings").Range("A1"), myFind, myReplace
'       Reset error checking
        On Error GoTo 0
    Next myRow

    Application.ScreenUpdating = True

End Sub
Sub ColorReplacement(aCell As Range, findText As String, ReplaceText As String, Optional ReplaceColor As OLE_COLOR = vbRed)
    Dim oText As String, nText As String, counter As Integer

    oText = aCell.Cells(1, 1).Text
    nText = Replace(oText, findText, ReplaceText, 1, 1000000)

    If oText <> nText Then
    aCell.Cells(1, 1).Value = nText
        For counter = 0 To Len(aCell.Cells(1, 1))
            If aCell.Characters(counter, Len(ReplaceText)).Text = ReplaceText Then
            aCell.Characters(counter, Len(findText) + 1).Font.Color = ReplaceColor
            End If
        Next
    End If

End Sub

Answer 1

Проблема в том, что вы переустанавливаете значение .Value для каждого поиска - это может испортить ваше форматирование.

Вам нужно сделать все, используя Characters

Sub tester()
    [a4].Copy [a1]
    ColorReplacement Range("a1"), "this", "This thing"
    ColorReplacement Range("a1"), "a test", "an exam"
End Sub


Sub ColorReplacement(aCell As Range, findText As String, ReplaceText As String, _
                     Optional ReplaceColor As OLE_COLOR = vbRed)

    Dim p As Long

    p = InStr(1, aCell.Text, findText, vbTextCompare)
    Do While p > 0
        aCell.Characters(p, Len(findText)).Text = ReplaceText
        aCell.Characters(p, Len(ReplaceText)).Font.Color = ReplaceColor
        p = InStr(p + Len(ReplaceText), aCell.Text, findText)
    Loop

End Sub