在文本字符串中查找文本字符串并将部分原始文本字符串替换为来自另一个单元格的红色文本字符串

Question

我有一个有 2 张纸的工作簿。工作表 1 单元格 A1 中有一个黑色文本。工作表 2 有两列我正在使用，A 列（查找列）和 B 列（替换列）。工作表 2 列 A（查找列）和 B（替换列）中有文本字符串。 Sheet 2 列 A（查找列）和 B（替换列）中的文本标记也是黑色的。

我正在尝试在工作表 1 单元格 A1 中搜索文本字符串，查看它是否包含来自工作表 2 单元格 A2（查找列）的文本字符串，如果包含，则将文本字符串的那部分替换为工作表 1 单元格 A1 与工作表 2 单元格 B1（替换列）中的文本字符串（红色文本版本）。

如果工作表 1 单元格 A1 包含来自工作表 2 列 A 中剩余使用行的文本字符串，我希望宏循环遍历工作表 2 列 A 中的所有已使用行，再次替换工作表中文本字符串的那部分1 个单元格 A1 与工作表 2 单元格 B1（替换列）中的文本字符串（红色文本版本）。

有更好的说法。但需要明确的是，我不想替换工作表 1 单元格 A1 的全部内容，只是替换工作表 2 单元格 B1 中的文本字符串（红色文本版本）。

查找替换部分效果很好。但我似乎无法让 Sheet 1 单元格 A1 中文本字符串的替换部分变为红色并保持红色。

任何帮助将不胜感激！

这是我目前正在使用的代码：

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