CODEWITHSUNDEEP
excelvba
user1271146
user1271146

Reputation: 45

In excel have to search for specific string in cell and apply style to that particular string

In excel I have to search for specific word in a cell and replace only that the particular word.

For example: In excel a cell may contain

"team should have loaded test data into the file"

I want to select only a single word in this line such as test and apply a style to that particular string

"team should have loaded test data into the file"

I have many cells to format so I would like to use VBA

Upvotes: 2

Views: 2525

Answers (2)

JMax
JMax

Reputation: 26591

Here is a snippet to show you how to format a piece of text in a cell:

Sub EditFont()
'To format font color for 12 digits to 4 black, 5 red, 3 black:

' Here is some sample text to try it on: 123456789012

'First, format digits to be treated as characters
ActiveCell.Value = "'" & ActiveCell.Value
'Format all characters for black
With ActiveCell
    .Font.ColorIndex = 3
    'Format characters 5 thru 12 as red
    .Characters(1, ActiveCell.Characters.Count - 8).Font.ColorIndex = 1
    'Reformat characters 10 thru 12 back to black
    .Characters(10, ActiveCell.Characters.Count - 3).Font.ColorIndex = 1
End With
End Sub

You will only have to add a loop over the needed cells.

[Source]

Upvotes: 2

brettdj
brettdj

Reputation: 55682

Something like this will change "test" in all cells in a user selected range to bold. It handles multiple occurrences in a single cell

The test is case insensitive

Option Explicit

Const strText As String = "test"

Sub ColSearch_DelRows()
Dim rng1 As Range
Dim rng2 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim strFirstAddress As String
Dim lAppCalc As Long
Dim objRegex As Object
Dim RegMC As Object
Dim RegM As Object

Set objRegex = CreateObject("vbscript.regexp")

With objRegex
    .Global = True
    .Pattern = strText
End With

'Get working range from user
On Error Resume Next
Set rng1 = Application.InputBox("Please select range to search for " & strText, "User range selection", Selection.Address(0, 0), , , , , 8)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub

With Application
    lAppCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , False)
If Not cel1 Is Nothing Then
    Set rng2 = cel1
    strFirstAddress = cel1.Address
    Do
        Set cel1 = rng1.FindNext(cel1)
        Set rng2 = Union(rng2, cel1)
    Loop While strFirstAddress <> cel1.Address
End If

If Not rng2 Is Nothing Then
    For Each cel2 In rng2
        Set RegMC = objRegex.Execute(cel2.Value)
        For Each RegM In RegMC
            cel2.Characters(RegM.firstindex, RegM.Length + 1).Font.Bold = True
        Next
    Next
End If

With Application
    .ScreenUpdating = True
    .Calculation = lAppCalc
End With

End Sub

Upvotes: 3

Related Questions