VBA to delete empty bullet points from PPT slides

[z1000]

Hi,

I've done a search for prior threads and I've turned up nothing. If it does exist and I've missed it, I apologize. Because PPT's find and replace feature is incapable of finding double hard returns within a slide (empty bullet points in between bullets), I would like to create a macro that does it for the 13 presentations with 170+ slides each. I'll attach some sample slides. In short, I'm looking for code to delete empty bullets within a list for the entire presentation. Thanks for your help in advance!!

[John Wilson]

Maybe something like :

TEST ON A COPY!!

Sub zapper()
   Dim osld As Slide
   Dim oshp As Shape
   Dim L As Long
   Dim lngCount As Long
   Dim otr As TextRange
   For Each osld In ActivePresentation.Slides
      For Each oshp In osld.Shapes
         If oshp.HasTextFrame Then
            If oshp.TextFrame.HasText Then
               Set otr = oshp.TextFrame.TextRange
               For L = otr.Paragraphs.Count To 1 Step -1
                  If Len(otr.Paragraphs(L)) < 2 Then otr.Paragraphs(L).Delete
                  If otr.Characters(otr.Count) = Chr(13) Then otr.Characters(otr.Count).Delete
               Next L
            End If
         End If
      Next oshp
   Next osld
End Sub

[z1000]

Ran it through some samples, and it works great! Thank you!

[RayKay]

Hi John

Great code, but could you tweak it to work in PPT 2013 onwards?

Thanks so much. I tinker with VBA (and HTML5) but this is beyond me. Debugger highlights:

If oshp.TextFrame.HasText Then

Thank you, sorry for all my queries today.

[John Wilson]

It should work in 2013 already.

You should really use TextFrame2 in later version but in this case it should work fine. Are you using my exact code?

Do I get a cut of your fee? ;-)

[RayKay]

Ah, thanks John, I was thinking it removed 'ghost' bullet points from tables. Works fine on text boxes.

Any way to adapt it so it removes ghost bullets in tables please?

Sadly, I won't get a bonus, I stupidly did this as 'voluntary' while work is quiet at Christmas! I'm learning a lot thanks to you. Just a few tools I can't find vba code, or work it out - I've made some code myself (I know some HTML5, but very little VBA).

Great website, and you must've helped thousands of people by now.

Thank you

[John Wilson]

This fixes a bug and included tables.

Sub zapper()    
Dim osld As Slide
    Dim oshp As Shape
    Dim L As Long
    Dim lngCount As Long
    Dim iRow As Integer
    Dim iCol As Integer
    Dim otr As TextRange
    For Each osld In ActivePresentation.Slides
        For Each oshp In osld.Shapes
            Select Case oshp.HasTable
            Case Is = True
                'loop through table
                For iRow = 1 To oshp.Table.Rows.Count
                    For iCol = 1 To oshp.Table.Columns.Count
                        If oshp.Table.Cell(iRow, iCol).Shape.TextFrame.HasText Then
                            Set otr = oshp.Table.Cell(iRow, iCol).Shape.TextFrame.TextRange


                            For L = otr.Paragraphs.Count To 1 Step -1
                                If L < otr.Paragraphs.Count Then
                                    If Len(otr.Paragraphs(L)) < 2 Then otr.Paragraphs(L).Delete
                                Else
                                    If Len(otr.Paragraphs(L)) < 1 Then otr.Paragraphs(L).Delete
                                End If
                                If otr.Characters(otr.Count) = Chr(13) Then otr.Characters(otr.Count).Delete
                                If otr.Characters(otr.Count) = Chr(13) Then otr.Characters(otr.Count).Delete
                            Next L
                        End If
                    Next iCol
                Next iRow
            Case Is = False
                If oshp.HasTextFrame Then
                    If oshp.TextFrame.HasText Then
                        Set otr = oshp.TextFrame.TextRange
                        For L = otr.Paragraphs.Count To 1 Step -1
                            Debug.Print Len(otr.Paragraphs(L))
                            If L < otr.Paragraphs.Count Then
                                If Len(otr.Paragraphs(L)) < 2 Then otr.Paragraphs(L).Delete
                            Else
                                If Len(otr.Paragraphs(L)) < 1 Then otr.Paragraphs(L).Delete
                            End If
                            If otr.Characters(otr.Count) = Chr(13) Then otr.Characters(otr.Count).Delete
                        Next L
                    End If
                End If
            End Select
        Next oshp
    Next osld
End Sub