Bolding words from text

vulpes_vulpes_3

New Member
Joined
Jul 24, 2018
Messages
4
I have raw text data in cell A1

I also have list of words that I want to be bolded to that cell. (These words are listed in column B)


I want it to be like this:
Bold every "Jack" and "John" in cell A1:

Jack and John are brothers. Jack is older than John.
Jack likes football but John hates it. John loves ice hockey instead.



Thank you!
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
75,831
Office Version
  1. 365
Platform
  1. Windows
Try this, it assumes the raw text data is in column A and the words to turn bold are in column C.
Code:
Function GetPos(strValue As String, strPattern As String, Optional blnCase As Boolean = True, Optional blnBoolean = True) As Variant
Dim objRegEx As Object
Dim objMatches As Object
Dim objMatch As Object
Dim arrPos() As Long
Dim cnt As Long

    Set objRegEx = CreateObject("VBScript.RegExp")
    
    With objRegEx
        .Global = "True"
        .Pattern = strPattern
        .IgnoreCase = blnCase
        
        If .test(strValue) Then
        
            Set objMatches = .Execute(strValue)
            ReDim arrPos(1 To objMatches.Count)
            
            For Each objMatch In objMatches
              cnt = cnt + 1
              arrPos(cnt) = objMatch.firstindex + 1
            Next objMatch
            
            GetPos = arrPos
            
        End If
        
    End With
    
End Function

Sub BoldStuff()
Dim rngPhrases As Range
Dim rngTerms As Range
Dim ph As Range
Dim tm As Range
Dim I As Long
Dim arrPos As Variant

    Set rngPhrases = Range("A1").CurrentRegion
    
    Set rngTerms = Range("C1").CurrentRegion
    
    For Each ph In rngPhrases.Cells
    
        For Each tm In rngTerms.Cells
        
            arrPos = GetPos(ph.Value, tm.Value)
            
            If Not IsEmpty(arrPos) Then
                For I = LBound(arrPos) To UBound(arrPos)
                    ph.Characters(arrPos(I), Len(tm)).Font.Bold = True
                Next I
            End If
        Next tm
        
    Next ph
    
End Sub
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this Data in "A1" , List in column "B".
Code:
[COLOR="Navy"]Sub[/COLOR] MG24Feb30
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, Lg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
    [a1] = Trim([a1])
    Sp = Split([a1], " "): Lg = 0
    [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
        Lg = Lg + Len(Sp(n)) + 1
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            [COLOR="Navy"]If[/COLOR] UCase(Sp(n)) = UCase(Dn.Value) Or UCase(Sp(n)) = UCase(Dn.Value & ".") [COLOR="Navy"]Then[/COLOR]
                [a1].Characters(Lg - Len(Sp(n)), Len(Sp(n))).Font.Bold = True
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

vulpes_vulpes_3

New Member
Joined
Jul 24, 2018
Messages
4
Norie's code bolds all words in all cells

Mick's code is mystery. It bolds only some of the words on my list. I have a word "milk" in my cell A1 six times but only three of them are bold. Very strange-
 

mikerickson

MrExcel MVP
Joined
Jan 15, 2007
Messages
23,785

ADVERTISEMENT

This should do what you want. (search terms in B:B)

Code:
Sub test()
    Dim rngRaw As Range, arrSearchTerms As Variant
    Dim aCell As Range
    Dim findString As Variant
    Dim startBold As Long
    
    With Range("A:A")
        Set rngRaw = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    With Range("C:C")
        With Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
            arrSearchTerms = .Value
        End With
    End With
    
    rngRaw.Font.Bold = False
    
    For Each aCell In rngRaw
        aCell.Font.ColorIndex = xlAutomatic
        For Each findString In arrSearchTerms
        If findString <> vbNullString Then
            Do
                startBold = startBold + 1
                startBold = InStr(startBold, aCell.Value, findString)
                
                If startBold > 0 Then
                    aCell.Characters(startBold, Len(findString)).Font.Bold = True
                End If
            Loop Until startBold = 0
        End If
        Next findString
    Next aCell
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,109,377
Messages
5,528,333
Members
409,817
Latest member
JiNXX9500

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top