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

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.stack.imgur.com/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:
You have PowerPoint open with an active presentation that has a slide at the begining with a Title and 5 texboxes properly named
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