Bolding words from text

[vulpes_vulpes_3]

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!

 

[Norie]

Try this, it assumes the raw text data is in column A and the words to turn bold are in column C.

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]

Try this Data in "A1" , List in column "B".

[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]

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]

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

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

 

[Norie]

The code I posted does not bold all words in all cells.

You can download a sample file from here - https://app.box.com/s/nnhu83flu9c0wpm4a5925cdifwpwmpbr

 

[vulpes_vulpes_3]

Thanks. mikerickson this is what i was looking for.