Loop Through Columns in Existing Worksheet - Paste Values to Existing PowerPoint as Textboxes

Question

Ive made a VBA macro that automatically creates a PowerPoint and one that creates a Worksheet named "Handlungsempfehlungen" with Text. The Worksheet "Handlungsempfehlungen" looks like this:

https://i.sstatic.net/nZEL8.png

It has about 40 columns (A-AO) and Text in each column from Row 1 to max. 34 (Number of rows filled with text varies each column). I now need to somehow loop through each row in each column and give each Cell.Value over to the existing (and currently opened) PowerPoint. Until now Ive used something like this to create textboxes in PowerPoint and fill them with Cell Values from Excel:

'New PPslide (copy slide 2 which is emtpy)
Set PPslide = PPapp.ActivePresentation.Slides(2).Duplicate.Item(1)
'Put new slide to end of PP
PPslide.MoveTo (PPpres.Slides.Count)
'Change title
PPslide.Shapes.Title.TextFrame.TextRange = "Slidetitle"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Second title"
'Insert Textbox
Set PPtextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=40, Top:=133, Width:=875, Height:=30)
PPtextbox.TextFrame.TextRange.Text = ActiveWorkbook.Worksheets("Handlungsempfehlungen").Cells(1, 1).Value

But with 40 columns and about 30 rows per column each filled with text I would need to create about 1000 textboxes and hand them to my PowerPoint. How could I loop through this Worksheet and automatically have positions on the PowerPoint Slide set for each textbox? The slidetitle for each PowerPointslide is already saved in the Row 35 of each Column in the Worksheet (see screenshot), so I would give this over to PP inside the loop as well (for each column set slidetitle = currentColumn.Row 35 is kinda the idea)

My current Idea for all of this is I having 5 textboxes per slide with set positions, filling them with the values from row 1-5 of the first column and then create a new slide and do the same process for rows 6-10 and so on until the Cell.Value in the current column is empty, then jump one column to the right and create a new PPslide again and repeat the whole process until the whole Worksheet has been worked through. I think this seems relatively simple but I am still a beginner and have difficulties implementing this.

Would this be a good idea and how would I need to get there? Im quite bad at looping but Im happy for every answer! Thanks for your time & help!

PS: the declarations for the created PP and its Objects:

Public Shape As Object
Public PPshape As PowerPoint.Shape
Public PPapp As PowerPoint.Application
Public PPpres As PowerPoint.Presentation
Public PPslide As PowerPoint.Slide
Public PPtextbox As PowerPoint.Shape

Set PPapp = New PowerPoint.Application
PPapp.Visible = msoTrue

Answer 1

The following code covers two scenarios:

1. You have PowerPoint open with an active presentation that has a slide at the begining with a Title and 5 texboxes properly named

2. You have PowerPoint closed

You need to set a reference to PowerPoint object model like this:

---

Read code's comments and try to adjust it to fit your needs

Use the F8 key to step into the code line by line

You can also add a Stop statement so the code breaks and then use the F8 key

---

Public Sub TransferDataToPPT()

    ' Set basic error handling
    On Error GoTo CleanFail

    ' Turn off stuff
    Application.ScreenUpdating = False
    
    Dim pptApp As PowerPoint.Application
    Dim pptPresentation As PowerPoint.Presentation
    Dim pptMainSlide As PowerPoint.Slide
    Dim pptContentSlide As PowerPoint.Slide
    
    Dim isNewPPTInstance As Boolean
   
    ' Open and get PowerPoint instance
    Set pptApp = OpenGetPowerPoint(isNewPPTInstance)
    
    ' If it's a new instance add new presentation and main slide
    If isNewPPTInstance Then
        pptApp.Visible = msoTrue
        Set pptPresentation = pptApp.Presentations.Add(msoTrue)
        Set pptMainSlide = pptPresentation.Slides.Add(1, ppLayoutTitleOnly)
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 150, 100, 20).Name = "Textbox1"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 200, 100, 20).Name = "Textbox2"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 250, 100, 20).Name = "Textbox3"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 300, 100, 20).Name = "Textbox4"
        pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 350, 100, 20).Name = "Textbox5"
    Else
        Set pptPresentation = pptApp.ActivePresentation
        Set pptMainSlide = pptPresentation.Slides(1)
    End If
    
    ' Set a reference to the sheet holding the values
    Dim contentSheet As Worksheet
    Set contentSheet = ThisWorkbook.Worksheets("Sheet1")
    
    ' Set the Excel range to be evaluated
    Dim contentRange As Range
    Set contentRange = contentSheet.Range("A1:AO34")
    
    ' Start a cell counter
    Dim cellCounter As Long
    cellCounter = 1
    
    ' Loop through columns and cells
    Dim contentColumn As Range
    Dim contentCell As Range
    For Each contentColumn In contentRange.Columns
        For Each contentCell In contentColumn.Cells
            
            ' Skip after first blank cell
            If contentCell.Value = vbNullString Then Exit For
            
            ' Add new slide every 5 cells and fill title
            If cellCounter = 1 Then
                Set pptContentSlide = pptPresentation.Slides(1).Duplicate()(1)
                pptContentSlide.MoveTo pptPresentation.Slides.Count
                pptContentSlide.Shapes.Title.TextFrame.TextRange = contentSheet.Cells(35, contentColumn.Column).Value
            End If
            
            ' Add value to textbox
            pptContentSlide.Shapes("Textbox" & cellCounter).TextFrame.TextRange = contentCell.Value
            
            cellCounter = cellCounter + 1
            
            ' Reset counter
            If cellCounter > 5 Then cellCounter = 1
            
        Next contentCell
    Next contentColumn
    

CleanExit:
    ' Turn on stuff again
    Application.ScreenUpdating = True
    
    If isNewPPTInstance Then
        If Not pptApp Is Nothing Then
            pptPresentation.SaveAs "C:\Temp\NewPPT.pptx"
            pptApp.Quit
        End If
    End If
    Set pptApp = Nothing
    Exit Sub
    
CleanFail:
    MsgBox "An error occurred:" & Err.Description
    GoTo CleanExit
    
End Sub

Private Function OpenGetPowerPoint(ByRef isNewPPTInstance As Boolean) As PowerPoint.Application
    Dim pptApp As PowerPoint.Application
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
         'PPT wasn't running, start it from code:
        Set pptApp = CreateObject("PowerPoint.Application")
        isNewPPTInstance = True
    End If
    
    Set OpenGetPowerPoint = pptApp
    
End Function

Let me know if it works