On 15 Jun., 18:26, Steve wrote:
Hi All,

With the code below:
Dim rng As Range
Dim cell As Range
Dim start_str As Integer
Dim FindText As Range
Dim Length As Integer

On Error Resume Next
* * Set FindText = Application.InputBox(prompt:= _
* * * * * * "Select Cell with Contents to Find", Type:=8)
* * * * If FindText Is Nothing Then
* * * * * * Exit Sub
* * * * End If
On Error GoTo 0

* * Set rng = Selection
* * Length = Len(FindText)

* * For Each cell In rng
* * * * start_str = InStr(cell.Value, FindText)
* * * * If start_str Then
* * * * * * cell.Characters(start_str, Length).Font.Bold = True
* * * * * * cell.Characters(start_str, Length).Font.Color = 192
* * * * End If
* * Next

I have an input box that alolows me to select a cell, which becomes
the "find" criteria to change the font in the selection. *Is there a
way to modify the code to allow me to select several cells via the
inputbox, and loop through each cell to do the "find and replace" on
the selection in one swoop?

Thanks!

Try this:

Dim rng As Range
Dim cell As Range
Dim start_str As Integer
Dim FindTextCells As Range
Dim Length As Integer
Dim FindText As String

Application.Screenupdating = False
On Error Resume Next
Set FindTextCells = Application.InputBox(prompt:= _
"Select Cell with Contents to Find" & vbLf & _
vbLf & "Press CTRL for multi-select", Type:=8)
If FindTextCells Is Nothing Then
Exit Sub
End If
On Error GoTo 0
Set rng = Selection

For Each txt In FindTextCells
FindText = txt
Length = Len(FindText)
For Each cell In rng
start_str = InStr(cell.Value, FindText)
If start_str Then
cell.Characters(start_str, Length).Font.Bold = True
cell.Characters(start_str, Length).Font.Color = 192
End If
Next
Next

Regards,
Per