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

Question

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

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

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

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

查找替换部件效果很好。 但是我似乎无法在工作表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