How to Duplicate Slides in PowerPoint and Update Text Using VBA?

I am trying to use VBA to automate the creation of 52 slides in PowerPoint, where each slide is a duplicate of the first slide but with updated text inside a text box. The goal is to have the slides display “Week 1,” “Week 2,” …, “Week 52” sequentially.

I’ve written a VBA script that successfully duplicates the slides, but the text in the text box is not being updated. The text box is not a placeholder; it’s a manually added text box on the slide.

Here’s the code I’m currently using:

Sub CreateWeeklySlides_TextBox()
    Dim ppt As Presentation
    Dim baseSlide As Slide
    Dim newSlide As Slide
    Dim shape As Shape
    Dim weekText As String
    Dim i As Integer
    
    ' Reference the active presentation
    Set ppt = ActivePresentation

    ' Reference the slide to duplicate (e.g., the first slide)
    Set baseSlide = ppt.Slides(1)

    ' Loop to create 51 additional slides (totaling 52)
    For i = 2 To 52
        ' Duplicate the base slide
        baseSlide.Duplicate

        ' Reference the newly created slide (it will always be the last slide)
        Set newSlide = ppt.Slides(ppt.Slides.Count)

        ' Loop through all shapes in the slide
        For Each shape In newSlide.Shapes
            ' Check if the shape is a text box
            If shape.HasTextFrame Then
                If shape.TextFrame.HasText Then
                    ' Replace the text box content with "Week X"
                    weekText = "Week " & i
                    shape.TextFrame.TextRange.Text = weekText

                    ' Center the text within the text box
                    shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter

                    ' Optionally center the text box on the slide
                    shape.Left = (ppt.PageSetup.SlideWidth - shape.Width) / 2
                    shape.Top = (ppt.PageSetup.SlideHeight - shape.Height) / 2
                End If
            End If
        Next shape
    Next i
End Sub