Find Text String Within a Text String and Replace Part of Original Text String With Red Text String From Another Cell

Question

I have a workbook with 2 sheets. Sheet 1 cell A1 has a black text sting in it. Sheet 2 has two columns I'm working with, column A (the find column) and column B (the replace column). Sheet 2 columns A (the find column) & B (the replace column) have text strings in them. The text stings in Sheet 2 columns A (the find column) and B (the replace column) are also black.

I'm trying to search the text string in Sheet 1 cell A1, see if it contains the text string from Sheet 2 cell A2 (the find column), and, if it does, replace that part of the text string in Sheet 1 cell A1 with (a red text version of) the text string in Sheet 2 cell B1 (the replace column).

I would like the macro to loop through all the used rows in Sheet 2 column A, if Sheet 1 cell A1 contains text string from the remaining used rows in Sheet 2 column A, again replacing that part of the text string in Sheet 1 cell A1 with (a red text version of) the text string in Sheet 2 cell B1 (the replace column).

There's a better way of saying that. But to be clear, I don't want to replace the entire contents of Sheet 1 cell A1, just (a red text version of) the text string from Sheet 2 cell B1.

The find replace part works great. But I can't seem to get the replaced parts of the text string in Sheet 1 cell A1 to turn red and stay red.

Any help would be greatly appreciated!

Here's the code I'm working with so far:

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

How long are the strings you're working on? Anything beyond about 255 characters will be a problem — Tim Williams
– Tim Williams, Commented Feb 22, 2019 at 18:33
Example: Sheet 1 cell A1 contains the (all black font) text string "This is a test and only a test." Sheet 2 cell A1 contains the (all black font) text "This" Sheet 2 cell B1 contains the (all black font) text "This thing" Sheet 2 cell A2 contains the (all black font) text "a text" Sheet 2 cell B2 contains the (all black font) text "an exam" After running my code I get... "<red>This</red> <black>thing is an exam and only an exam</black>." — Jared
– Jared, Commented Feb 22, 2019 at 19:20
What I want is... "<red>This thing</red> <black>is</black> <red>an exam</red> <black>and only</black> <red>an exam</red>." Apologies in advance for lack of pictures, et cetera. I'm new :) — Jared
– Jared, Commented Feb 22, 2019 at 19:20
The strings I'm working on will be less than 255 characters. So, that's good. — Jared
– Jared, Commented Feb 22, 2019 at 19:47

Tim Williams · Accepted Answer · 2019-02-22 20:54:39Z

0

The problem is you're re-setting the .Value for each search - that will mess up your formatting.

You need to do everything using 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

answered Feb 22, 2019 at 20:54

Tim Williams

169k8 gold badges104 silver badges144 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

Jared Over a year ago

Tim, you are the man. Been searching for this one for a long time. Even the YouTube gurus that post a daily Q&A have been stumped by this one. I owe you one, my friend! Thank you! Thank you!

Collectives™ on Stack Overflow

Find Text String Within a Text String and Replace Part of Original Text String With Red Text String From Another Cell

1 Answer 1

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related