Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

VBA Macro in PowerPoint to Differentiate Duplicate Slide Titles 1

Status
Not open for further replies.

j.iverson

Technical User
Apr 17, 2020
4
US
Hello,

After playing around for hours, I've run into a wall on this one. I have reoccurring 300+ slide presentations brought to me weekly, which are split in three to five sections, each section using the same title repeatedly. For accessibility purposes (specifically addressing users utilizing screen reader software), I must change the slides titles to be unique. For example, the original titles for the first part of the presentation read: Current Events, repeated 86 times. That should be changed to: Current Events (1), Current Events (2), Current Events (3), and so on.

The titles are specifically formatted as titles, not text boxes. I need the macro to reset the number sequence any time a new set of duplicate titles is encountered rather than just continuing on a single sequence (i.e. Current Events (86), then on to Breakdown (1)).

Surely there is a way to code a solution? Thank you in advance for your time and assistance, you have no idea how much I appreciate it!
 
Something like

Code:
[blue]Public Sub RenameSlides()
    Dim myPres As Presentation
    Dim myslide As Slide
    Dim dict As Object
    
    Set dict = CreateObject("scripting.dictionary")
    Set myPres = ActivePresentation
    
    For Each myslide In myPres.Slides
        If myslide.Shapes.HasTitle Then
            dict.Item(myslide.Shapes.Title.TextFrame.TextRange.Text) = dict.Item(myslide.Shapes.Title.TextFrame.TextRange.Text) + 1
            myslide.Shapes.Title.TextFrame.TextRange.Text = myslide.Shapes.Title.TextFrame.TextRange.Text & " (" & dict.Item(myslide.Shapes.Title.TextFrame.TextRange.Text) & ")"
       End If
    Next
    
End Sub[/blue]
 
Thanks, strongm! This works perfectly. I cannot tell you how much I appreciate it.
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top