Is it possible to use powerpoint macro to highlight text according to an excel list?

[yanlok1345]

[Thank you all for your help! That's brilliant. Please accept my apology that I was in the hospital and cannot respond to all your contribution. Words are not enough to express my gratitude.]

Is it possible to use PowerPoint macro to highlight text according to an excel list?

I have a word macro that can highlight text according to an excel list. But it cannot be used in the PowerPoint.

Is there any ways to achieve that?

Many thanks for your help!

[snb]

I have a word macro that can highlight text according to an excel list

What does this macro look like ?

[HansV]

The following will highlight specific words, but it also changes the font size. I'll try to find out how to prevent that. In the meantime, if others have suggestions, please post them.

Code: Select all

Sub HighlightWords()
    Dim objXL As Object
    Dim objWB As Object
    Dim objWS As Object
    Dim objRG As Object
    Dim objCL As Object
    Dim f As Boolean
    Dim pptPrs As Presentation
    Dim pptSld As Slide
    Dim pptShp As Shape
    Dim strFind As String
    Dim rngAll As TextRange2
    Dim rngTxt As TextRange2

    On Error Resume Next
    Set objXL = GetObject(Class:="Excel.Application")
    On Error GoTo ErrHandler
    If objXL Is Nothing Then
        Set objXL = CreateObject(Class:="Excel.Application")
        f = True
    End If

    ' ****** Change the path and filename ******
    Set objWB = objXL.Workbooks.Open(FileName:="C:\\Excel\Book.xlsx")
    Set objWS = objWB.Worksheets(1)
    Set objRG = objWS.Range(objWS.Range("A1"), objWS.Range("A1").End(-4121)) ' xlDown

    Set pptPrs = ActivePresentation
    For Each objCL In objRG
        strFind = objCL.Value
        For Each pptSld In pptPrs.Slides
            For Each pptShp In pptSld.Shapes
                If pptShp.HasTextFrame Then
                    If pptShp.TextFrame.HasText Then
                        Set rngAll = pptShp.TextFrame2.TextRange
                        Set rngTxt = rngAll.Find(FindWhat:=strFind, WholeWords:=True)
                        Do While rngTxt.Text <> ""
                            rngTxt.Font.Highlight.RGB = vbYellow
                            Set rngTxt = rngAll.Find(FindWhat:=strFind, _
                                After:=rngTxt.Start + rngTxt.Length - 1, WholeWords:=True)
                        Loop
                    End If
                End If
            Next pptShp
        Next pptSld
    Next objCL

ExitHandler:
    On Error Resume Next
    If f Then
        objXL.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[SpeakEasy]

I have similar code to HansV, and I also have the odd and unexpected change in font size

[SpeakEasy]

Ok, looks like a bug. Font size is changes when you set the highlight colour. Workaround is to capture the current font size of the rngTxt just before setting the highlight, and then set the font size to that captured value just after.

Irritating, but the only solution I could figure out.

[HansV]

Thanks! That does work.

Code: Select all

Sub HighlightWords()
    Dim objXL As Object
    Dim objWB As Object
    Dim objWS As Object
    Dim objRG As Object
    Dim objCL As Object
    Dim f As Boolean
    Dim pptPrs As Presentation
    Dim pptSld As Slide
    Dim pptShp As Shape
    Dim strFind As String
    Dim rngAll As TextRange2
    Dim rngTxt As TextRange2
    Dim sngFontSize As Single

    On Error Resume Next
    Set objXL = GetObject(Class:="Excel.Application")
    On Error GoTo ErrHandler
    If objXL Is Nothing Then
        Set objXL = CreateObject(Class:="Excel.Application")
        f = True
    End If

    ' ****** Change the path and filename! ******
    Set objWB = objXL.Workbooks.Open(FileName:="C:\Excel\Book.xlsx")
    Set objWS = objWB.Worksheets(1)
    Set objRG = objWS.Range(objWS.Range("A1"), objWS.Range("A1").End(-4121)) ' xlDown

    Set pptPrs = ActivePresentation
    For Each objCL In objRG
        strFind = objCL.Value
        For Each pptSld In pptPrs.Slides
            For Each pptShp In pptSld.Shapes
                If pptShp.HasTextFrame Then
                    If pptShp.TextFrame.HasText Then
                        Set rngAll = pptShp.TextFrame2.TextRange
                        Set rngTxt = rngAll.Find(FindWhat:=strFind, WholeWords:=True)
                        Do While rngTxt.Text <> ""
                            sngFontSize = rngTxt.Font.Size
                            rngTxt.Font.Highlight.RGB = vbYellow
                            rngTxt.Font.Size = sngFontSize
                            Set rngTxt = rngAll.Find(FindWhat:=strFind, _
                                After:=rngTxt.Start + rngTxt.Length - 1, WholeWords:=True)
                        Loop
                    End If
                End If
            Next pptShp
        Next pptSld
    Next objCL

ExitHandler:
    On Error Resume Next
    If f Then
        objXL.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[snb]

Running from Excel:

Code: Select all

Sub M_snb()
  c00 = "_" & Join(Application.Transpose(Sheet1.Cells(1).CurrentRegion.Columns(1)), "_")
   
  With GetObject("G:\powerpoint\De Zaak algemeen.ppt")
    For Each it In .slides
      For Each it1 In it.Shapes
        If it1.hastextframe Then
          For Each it2 In it1.TextFrame2.TextRange.Words
            If InStr(c00, "_" & Trim(it2) & "_") Then it2.Font.Highlight.RGB=65535
          Next
        End If
      Next
    Next
    .Save
    .Close
  End With
End Sub

NB. No change in Fontsize.

Running in Powerpoint:

Code: Select all

Sub M_snb()
   With GetObject("G:\OF\list.xlsb")
       c00 = "_" & Join(.Application.Transpose(.Sheets(1).Cells(1).CurrentRegion.Columns(1)), "_")
       .Close 0
    End With
   
     With ActivePresentation
     For Each it In .Slides
        For Each it1 In it.Shapes
           If it1.HasTextFrame Then
            For Each it2 In it1.TextFrame2.TextRange.Words
               If InStr(c00, "_" & Trim(it2) & "_") Then it2.Font.Highlight.RGB=65535
            Next
           End If
        Next
     Next
    .Save
    .Close
  End With
End Sub

[SpeakEasy]

>No change in Fontsize

Absolutely. Bug only seems to trigger if we mess with the Highlight property of TextFrame2's TextRange property (which is in fact a TextRange2 object). The older TextFrame doesn't have the bug - but then it doesn't have the Highlight property.

[yanlok1345]

Thanks! That does work.

Code: Select all

Sub HighlightWords()
    Dim objXL As Object
    Dim objWB As Object
    Dim objWS As Object
    Dim objRG As Object
    Dim objCL As Object
    Dim f As Boolean
    Dim pptPrs As Presentation
    Dim pptSld As Slide
    Dim pptShp As Shape
    Dim strFind As String
    Dim rngAll As TextRange2
    Dim rngTxt As TextRange2
    Dim sngFontSize As Single

    On Error Resume Next
    Set objXL = GetObject(Class:="Excel.Application")
    On Error GoTo ErrHandler
    If objXL Is Nothing Then
        Set objXL = CreateObject(Class:="Excel.Application")
        f = True
    End If

    ' ****** Change the path and filename! ******
    Set objWB = objXL.Workbooks.Open(FileName:="C:\Excel\Book.xlsx")
    Set objWS = objWB.Worksheets(1)
    Set objRG = objWS.Range(objWS.Range("A1"), objWS.Range("A1").End(-4121)) ' xlDown

    Set pptPrs = ActivePresentation
    For Each objCL In objRG
        strFind = objCL.Value
        For Each pptSld In pptPrs.Slides
            For Each pptShp In pptSld.Shapes
                If pptShp.HasTextFrame Then
                    If pptShp.TextFrame.HasText Then
                        Set rngAll = pptShp.TextFrame2.TextRange
                        Set rngTxt = rngAll.Find(FindWhat:=strFind, WholeWords:=True)
                        Do While rngTxt.Text <> ""
                            sngFontSize = rngTxt.Font.Size
                            rngTxt.Font.Highlight.RGB = vbYellow
                            rngTxt.Font.Size = sngFontSize
                            Set rngTxt = rngAll.Find(FindWhat:=strFind, _
                                After:=rngTxt.Start + rngTxt.Length - 1, WholeWords:=True)
                        Loop
                    End If
                End If
            Next pptShp
        Next pptSld
    Next objCL

ExitHandler:
    On Error Resume Next
    If f Then
        objXL.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Many thanks for your help! It does work! May I ask if it can also apply wildcards? It means:

In Excel:

Column A:
A[BC]

Column B(title = Wildcard):
T

In PPT(after running the macro):

AB (highlighted in yellow)
AC (highlighted in yellow)

[HansV]

That would be complicated.
Why not simply specify AB and AC in separate cells?

[snb]

@Speakeasy

I tested my adapted (Textframe2 &highlight.RGB) suggestion.
No interference with fontsize either.

[snb]

@yanlok

Just give some examples, please.
Do you mean ?

A*
*A
??A
A??
*??A*
*A??*

[SpeakEasy]

>complicated.
Oh, I think that might depend on your definition of 'complicated"!

So, two steps.

1) My code that does pretty much what HansV's does:

Code: Select all

Public Sub example()
    Dim sld
    Dim shp As Shape
    Dim xRng As TextRange2
    Dim xFind As TextRange2
    Dim Wordlist As Variant
    Dim WordSearch As Variant
    Dim originalfontsize As Single
    
    Wordlist = Array("Hello", "Mike", "no") ' your source would be from Excel
    
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.TextFrame.HasText Then
                Set xRng = shp.TextFrame2.TextRange
                For Each WordSearch In Wordlist
                    Set xFind = xRng.Find(FindWhat:=WordSearch)
                    If Not (xFind.Text = "") Then
                        originalfontsize = xFind.Font.Size
                        xFind.Font.Highlight.RGB = RGB(255, 0, 0)
                        xFind.Font.Size = originalfontsize
                    End If
                Next
            End If
        Next shp
    Next sld
    
End Sub

2) And the slightly modified version that handles wildcards (meeting regexp definition of wildcards)

Code: Select all

' Reference to Microsoft VbScript Regular Expressions required
Public Sub example2()
    Dim sld
    Dim shp As Shape
    Dim xRng As TextRange2
    Dim xFind As TextRange2
    Dim Wordlist As Variant
    Dim WordSearch As Variant
    Dim originalfontsize As Single
    Dim WildWord As Variant
    
    Dim re As New RegExp
    Dim mymatches As MatchCollection
    
    re.Global = True
    re.Multiline = True
    re.IgnoreCase = True
    
    Wordlist = Array("a[bc]", ".oon", "Hello", "Mike", "no") ' your source would be from Excel
    
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.TextFrame.HasText Then
                Set xRng = shp.TextFrame2.TextRange
                For Each WildWord In Wordlist
                    re.Pattern = WildWord
                    If re.Test(xRng.Text) Then
                        Set mymatches = re.Execute(xRng.Text)
                        For Each WordSearch In mymatches
                            Set xFind = xRng.Find(FindWhat:=WordSearch)
                            If Not (xFind.Text = "") Then
                                originalfontsize = xFind.Font.Size
                                xFind.Font.Highlight.RGB = RGB(255, 255, 0)
                                xFind.Font.Size = originalfontsize
                            End If
                        Next
                    End If
                Next
            End If
        Next shp
    Next sld
    
End Sub

[SpeakEasy]

@Speakeasy

I tested my adapted (Textframe2 &highlight.RGB) suggestion.
No interference with fontsize either.

@snb Interesting. I also tested it, and it had the same behaviour - changing the font size. So perhaps this is Powerpoint version dependant. I'm using Powerpoint 2021

[snb]

I tested in Office 2010.

[SpeakEasy]

Now this is odd. I've now retested the 'snb version', and this time the font didn't change size ... hmm.

[snb]

Some magic in the air....

[HansV]

Thanks, gentlemen!

[snb]

If you want to use 'wildcards' it can be done
Instr is inherently 'wildcardy'. (like 'filter' and 'replace')

To use A*

Code: Select all

            For Each it2 In it1.TextFrame2.TextRange.Words
               If InStr(c00, "_" & Trim(it2)) Then it2.Font.Highlight.RGB=65535
            Next

To use *A

Code: Select all

            For Each it2 In it1.TextFrame2.TextRange.Words
               If InStr(c00, Trim(it2) & "_") Then it2.Font.Highlight.RGB=65535
            Next

[yanlok1345]

Thank you all for your help! That's brilliant. Please accept my apology that I was in the hospital and cannot respond to all your contribution. Words are not enough to express my gratitude.