Find and highlight only certain text within a cell

[wiegs187]

Hi. I'm writing a macro to loop through each row (column B only) and look for a certain string of text then color that text red. I don't want all the text in the cell red, only the string I'm looking for. For example, a cell will have this text in it:

010 601 0) 030 641 1.3) 040 685 5)

I need a macro to find 641 and make them red, but just them, not everything else in the cell. The text length varies by cell and the number I'm looking for could be anywhere.

Any help on how to do this would be greatly appreciated.

Thanks.

Bob

 

[VoG]

Try like this

Sub red()
With Range("B1")
    .Characters(InStr(.Value, "641"), 3).Font.Color = vbRed
End With
End Sub

 

[wiegs187]

Perfect. Thank you!

 

[wiegs187]

I have an issue. Some cells contain the value I'm looking to color and some don't. In the ones that don't, that piece of code colors the first 3 characters no matter what they are. How do I get around that? I forgot to mention that in the first post.

 

[VoG]

Try

Sub red()
Dim LR As Long, i As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To LR
    With Range("B" & i)
        If InStr(.Value, "641") <> 0 Then .Characters(InStr(.Value, "641"), 3).Font.Color = vbRed
    End With
Next i
End Sub

 

[wiegs187]

That'll do. Thanks!

 

[anandr]

That'll do. Thanks!

Dear Friends,

I have same problem

I need to highlight searched string in the whole sheet.

MY CODE which is for MUlti sheet selection:
and I get result in NEW Sheet Called "Results"
whr I need my searched text should be RED.

Dim i As Long, rFind As Range, sFind As String, ws As Worksheet, sAddress As String, vItem
Dim rFind2 As Range, cAddress As String
Dim daddress As String
Dim currentSheet As Integer
currentSheet = ActiveSheet.Index
Sheets("Results").Rows("2:2000").Delete Shift:=xlUp
sFind = Application.InputBox("Please Enter the Keyword or Incident Number to Search .", "Search in ALL MOD & Highlight")
If sFind = "" Then Exit Sub
sFind = Replace(sFind, " ", "")
vItem = Split(sFind, ",")
Dim lIndex As Long
For lIndex = 0 To ListBox1.ListCount - 1
'Selectd(index) returns true if the item in the list box is selected
If ListBox1.Selected(lIndex) = True Then
Sheets(lIndex + 3).Activate
With Sheets(lIndex + 3).UsedRange
'Reset starts here automatically'

For k = 3 To 5000
If ActiveSheet.Range("E" & k).Interior.Color = 65535 Then
Range("E" & k).EntireRow.Interior.ColorIndex = xlNone

End If
Next k
'Reset Ends here
Set rFind = .Find(What:=vItem(0), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

' End If

If rFind Is Nothing Then GoTo line0 'if search on this sheet finds nothing, goto next sheet

If Not rFind Is Nothing Then ' if however it finds something, then...
daddress = rFind.Address
' MsgBox ("first keyword found in " & rFind.Address) 'debug - display the cell it has found the first keyword in
For i = 1 To UBound(vItem) ' now searches this cell through all other keywords (from the second word onwards)
Set rFind2 = rFind.Find(What:=vItem(i), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If rFind2 Is Nothing Then GoTo carryonsearch
Next i
' If rFind2 Is Nothing Then GoTo line0 ' if it doesnt find another keyword, it goes to next sheet

rFind.EntireRow.Interior.ColorIndex = 6
rFind.Font.Bold = True


If rFind2 Is Nothing Then 'if the second keyword isnt found, then continue searching
carryonsearch:
Set rFind = .Find(What:=vItem(0), After:=rFind, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

' MsgBox ("first keyword found in " & rFind.Address) 'debug - display the cell it has found the first keyword in


For i = 1 To UBound(vItem) ' now searches this cell through all other keywords (from the second word onwards)
Set rFind2 = rFind.Find(What:=vItem(i), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If daddress = rFind.Address Then GoTo Here

If rFind2 Is Nothing Then GoTo carryonsearch

Next i

rFind.EntireRow.Interior.ColorIndex = 6
rFind.Font.Bold = True
End If
Here:

sAddress = rFind.Address
' MsgBox ws.Name & " " & sAddress
carryonsearch2:
Do
Set rFind = .Find(What:=vItem(0), After:=rFind, LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFind Is Nothing Then 'if it finds a match to the first keyword


If sAddress = rFind.Address Then GoTo line0

For i = 1 To UBound(vItem)
Set rFind2 = rFind.Find(What:=vItem(i), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If rFind2 Is Nothing Then GoTo carryonsearch2
'If rFind2 Is Nothing Then GoTo line1

Next i
rFind.EntireRow.Interior.ColorIndex = 6
rFind.Font.Bold = True

End If

If Not rFind2 Is Nothing Then

End If

line1:
Loop While rFind.Address <> sAddress
End If
End With
End If
line0:
Next lIndex