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.: pray2:

[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