Find & Replace Font Color For Part of Text

[deluxe_247]

I have a workbook with 2 sheets. Sheet 1 cell A1 has a (black) text sting in it. Sheet 2 has two cells I'm working with, cells A1 and B1. The text stings in Sheet 2 cells A1 and B1 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 B1, 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 Sheet 2 cell A1.

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 text string to turn red.

Any help would be greatly appreciated!

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

Sub TextReplace()


Dim Findtext As String
Dim Replacetext As String

With Sheets("Sheet1")
.Activate


Findtext = Sheets("Sheet2").Range("B1").Value
Replacetext = Sheets("Sheet2").Range("A1").Value.Font.Color = RGB(255, 0, 0)


Cells.Replace What:=Findtext, Replacement:=Replacetext, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


End With


End Sub

 

[mikerickson]

Try this

sub Test()
    ColorReplacement Sheets("Sheet1").Range("A1"), Sheets("Sheet2").Range("B1"), Sheets("Sheet2").Range("A1")
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
   
    oText = aCell.Cells(1, 1).Text
    nText = Replace(oText, findText, ReplaceText, 1, 1)
    If oText <> nText Then
        aCell.Cells(1, 1).Value = nText
        aCell.Characters(InStr(1, oText, findText), Len(ReplaceText)).Font.Color = ReplaceColor
    End If
End Sub

 

[deluxe_247]

Mike,

You are THE man! Works amazingly!

I've searched dozens of posts over the years (for a variety of different issues I've been working on). And I'm super impressed with how helpful you are. Very, very kind of you. Can't thank you enough!

 

[deluxe_247]

Related question: If I wanted to expand that find/replace, could it be done?


In other words, after searching the text string in Sheet 1 cell A1 to see if it contains the text string from Sheet 2 cell B1, et cetera, could the find/replace process be repeated for the text strings in Sheet 2 cells B2, B3, and so on (changing the replaced parts of text string red and the rest of the text string black)?

 

[mikerickson]

Any of the arguments passed to ColorReplacement can be looped.

 

[deluxe_247]

Thanks, Mike.


Update: I've rewritten some things to loop the code you gave me. (Thanks again, for your help with that.) And the find/replace part works great. But the text that remains red is the text from the final find/replace performed.


So, getting there. But is there a way to have all the text strings that were replaced stay red, rather than just the text from the final find/replace?


Here's the code I'm working with:


Sub FindReplace()


Dim myStringsSheet 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 Strings sheet
Set myStringsSheet = Sheets("Sheet1")

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

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

Application.ScreenUpdating = False

'ColorReplacement Sheets("Sheet1").Range("B1"), Sheets("Synonyms").Range("B1"), Sheets("Synonyms").Range("A1")


' 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, "B")
myReplace = myReplaceSheet.Cells(myRow, "A")
' Start at top of data sheet and do replacements
myStringsSheet.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("Sheet1").Range("B1"), 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

oText = aCell.Cells(1, 1).Text
nText = Replace(oText, findText, ReplaceText, 1, 1)
If oText <> nText Then
aCell.Cells(1, 1).Value = nText
aCell.Characters(InStr(1, oText, findText), Len(ReplaceText)).Font.Color = ReplaceColor
End If
End Sub

 

[deluxe_247]

*the only text that remains red...

 

[deluxe_247]

Update: working well with multiple find/replaces. But only the final rind/replace remains red.

Here's the updated code I'm working with.

Suggestions?

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