Excel to PowerPoint VBA Loop - excel

Fist of all, I'm not good with VBA, and to be honest I don't know how to go about on this problem.
The Situation
I have a database as shown below with multiple entries (currently only 2, but there will be more as soon as the students will progress with there work). I want to be able to filter the database and then depending on the selection put the information in a PowerPoint Slide.
I created (with a lot of youtube videos) a script that will copy the relevant information from one line onto a PowerPoint presentation into the defined fields.
Problem
I have absolutely no idea how to loop that code in order to bring only the filtered Information onto the PowerPoint. Can someone guide me on how to go about it?
Sub XLS_to_PPT()
Dim pptPres As Presentation
Dim strPfad As String
Dim strPOTX As String
Dim pptApp As Object
strPfad = "C:XXX"
strPOTX = "PPT_Template.pptx"
Set pptApp = New PowerPoint.Application
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
pptPres.Slides(1).Duplicate
pptPres.Slides(1).Select
pptPres.Slides(1).Shapes("Header").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(5, 5).Value
pptPres.Slides(1).Shapes("ClientChanlenge").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(5, 9).Value
pptPres.Slides(1).Shapes("HowWeHelped").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(5, 10).Value
pptPres.SaveAs strPfad & ("New_Request")
pptPres.Close
Set pptPres = Nothing
Set pptApp = Nothing
End Sub

The plan is to create a new slide for each visible row in the table, i presume.
so you could loop through the table like this:
For Each tableRow In Sheets("NameOfYourSheet").ListObjects("NameOfYourTable").DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
set newSlide = pptPres.Slides(1).Duplicate
newSlide.Shapes("Header").TextFrame.TextRange.Characters.Text = tableRow.Columns(5).Value
newSlide.Shapes("ClientChanlenge").TextFrame.TextRange.Characters.Text = tableRow.Columns(9).Value
newSlide.Shapes("HowWeHelped").TextFrame.TextRange.Characters.Text = tableRow.Columns(10).Value
Next tableRow
Basically we go through each row in the table, duplicate slide(1), use that new slide object to populate the shapes inside by the given column numbers.
SpecialCells(xlCellTypeVisible) takes care of ignoring the filtered out rows.

try looking into this answer.
There it is described how to loop through a filtered list. There is information there how to get the address of the cell in you are looping through and so on
edit: after I got reprimanded I am posting full solution. Hope it works.
edit2: now made it so it works for arbitrary number of slides
Sub XLS_to_PPT()
Dim pptPres As Presentation
Dim strPfad As String
Dim strPOTX As String
Dim pptApp As Object
strPfad = "C:XXX"
strPOTX = "PPT_Template.pptx"
Set pptApp = New PowerPoint.Application
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
'below if set the range to 500 but you may want to increase /decrease that number depending on how many entries you expecty
Set rng = Range("A5:A500")
For Each cl In rng.SpecialCells(xlCellTypeVisible)
set mynewslide=pptPres.Slides(1).Duplicate
' I do not think you need below line
'pptPres.Slides(1).Select
mynewslide.Shapes("Header").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(cl.row, 5).Value
mynewslide.Shapes("ClientChanlenge").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(cl.row, 9).Value
mynewslide.Shapes("HowWeHelped").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(cl.row, 10).Value
Next cl
pptPres.SaveAs strPfad & ("New_Request")
pptPres.Close
Set pptPres = Nothing
Set pptApp = Nothing
End Sub

Related

How to copy PPT chart data to XLS most efficiently with VBA

I need to copy chart data from hundreds of PPTX files, each having approx. 40 charts, into an Excel file. This code here runs, after some trial and error, stable, but takes about 2-3 minutes per file. I wonder if there is a faster way to extract the data from the PPTs?
Many thanks for any ideas...
Marco
Sub CopyPPTChartdataToXLS()
Dim ppApp, ppFile, ppSlide, ppShape As Object
Dim ppSlideNr, ppShapeNr As Byte
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Sheets(1) 'this is the worksheet to insert the data
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = True
Set ppFile = ppApp.Presentations.Open(Filename:="c:\dummyFile.pptx")
For ppSlideNr = 1 To ppFile.Slides.Count 'runs through all slides
Set ppSlide = ppFile.Slides(ppSlideNr)
For ppShapeNr = 1 To ppSlide.Shapes.Count 'runs through all shapes on slide
Set ppShape = ppSlide.Shapes(ppShapeNr)
With ppShape.Chart.ChartData.Workbook
wsDestination.Range("A2:J101").Value = .Sheets(1).Range("A1:J100").Value
.Close
End With
End If
Call DataProcessing 'sub will use the data for quality checks
Next ppShapeNr
Next ppSlideNr
Set ppSlide = Nothing
Set ppShape = Nothing
Set ppFile = Nothing
Set ppApp = Nothing
End Sub

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

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
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

Excel to PowerPoint VBA

I am trying to paste few cells from Excel to a slide in PowerPoint, using an ActiveX CheckBox in Excel as control. There is no problem of transferring one slide to my designated PowerPoint Presentation, but the problem appears when I ticked more than one box.
So what I do is basically making a temporary template presentation, and when I click on another button called the "Launch" button, it will be pasted to my designated presentation. This is my code:
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
Dim PPSlide As PowerPoint.Slide
Dim PPPres As PowerPoint.Presentation
Dim PP As PowerPoint.Application
Set PP = CreateObject("PowerPoint.Application")
Set PPPres = PP.Presentations.Open("(my temporary filename)")
Dim iCheckCount As Integer
iCheckCount = 0
Dim obj As OLEObject
For Each obj In ActiveSheet.OLEObjects
If obj.Object.Value = True Then iCheckCount = iCheckCount + 1
Next
If iCheckCount = 1 Then
Set PPSlide = PPPres.Slides(1)
With PPSlide
.Shapes("Textfeld 2").TextFrame.TextRange.Text = ActiveSheet.Range("G3").Text
.Shapes("Textfeld 3").TextFrame.TextRange.Text = ActiveSheet.Range("B3").Text
.Shapes("Textfeld 4").TextFrame.TextRange.Text = ActiveSheet.Range("C3").Text
.Shapes("Textfeld 5").TextFrame.TextRange.Text = ActiveSheet.Range("D3").Text
.Shapes("Textfeld 6").TextFrame.TextRange.Text = ActiveSheet.Range("F3").Text
End With
PPPres.Slides(1).Copy
Else
If iCheckCount > 1 Then
PPPres.Slides.Paste
PPPres.Slides(2).Copy
Set PPSlide = PPPres.Slides(1)
With PPSlide
.Shapes("Textfeld 2").TextFrame.TextRange.Text = ActiveSheet.Range("G3").Text
.Shapes("Textfeld 3").TextFrame.TextRange.Text = ActiveSheet.Range("B3").Text
.Shapes("Textfeld 4").TextFrame.TextRange.Text = ActiveSheet.Range("C3").Text
.Shapes("Textfeld 5").TextFrame.TextRange.Text = ActiveSheet.Range("D3").Text
.Shapes("Textfeld 6").TextFrame.TextRange.Text = ActiveSheet.Range("F3").Text
End With
End If
End If
End If
End Sub
I know that it won't work for more than 2 boxes (copied to designated Presentation). So my questions are:
1) How can you copy more than 1 Slide at once? I´ve tried
For i = 1 to PPPres.Slides.Count
PPPres.Slides.Item(i).Copy
Next i
but it won't work.
2) I found an if code for every ticked ActiveX CheckBox I have. But the problem is, how can I mention all the Sub for CheckBox_Click and ask the program to do it? The names of the Sub are Box1, Box2, Box3,...,Box46.
I know that my questions are really messy and I'm not explaining it very well since I am also new to VBA. Don't hesitate to ask me if you want to know more about my code.
Thankyou!
You may use e.g:
ActivePresentation.Slides.Range(Array(1, 2, 3)).Duplicate
' Or
For i = 1 to PPPres.Slides.Count
PPPres.Slides.Item(i).Duplicate
Next i

Reading data from a table does not work in particular table

I am currently trying to create a new PPT presentation by deleting unwanted slides from a presentation. The slides - and their slide numbers - are being selected in the first column of a table I have in Excel.
I tried to solve this problem by taking another table instead of the one I want to use and it worked. For some reason it seems not work with the "Table 3".
Sub CreatingNewPresentation()
Dim Destination1PPT As String
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim myTable As ListObject
Dim TempArray As Variant
Dim x As Long
If MsgBox("This can take a while", vbOKCancel + vbExclamation, "Creating new presentation") = vbCancel Then
Exit Sub
Else
Set ppApp = CreateObject("PowerPoint.Application")
Destination1PPT = "C:\Users\Steffen\Desktop\Test2\1.pptx"
Set ppPres = ppApp.Presentations.Open(Destination1PPT)
ppApp.Visible = True
ppApp.Activate
Set myTable = ActiveSheet.ListObjects("Table3")
TempArray = myTable.ListColumns(1).DataBodyRange
For x = ppApp.ActivePresentation.Slides.Count To 1 Step -1
If IsError(Application.Match(x, TempArray, False)) Then
ppApp.ActivePresentation.Slides(x).Delete
End If
Next
End If
End Sub
I expect the code to open the presentation and delete all slides except the ones I store in "Table3" - column 1.
What it does instead is just open the presentation and nothing else. There is no error message.
I found the "stupid" mistake I made. I was getting ALL data entries of the referred table instead only getting the visible data entries.
This helps:
Set myTable = ThisWorkbook.Sheets("Sheet1").ListObjects("Table3")
TempArray = myTable.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible)

Grab Excel Hyperlink & Insert into PowerPoint Table

I'm following up to two questions (Here & Here) that were asked regarding this issue of using VBA to grab a hyperlink from Excel and insert it into PowerPoint.
Below is the code I have - I've tried tweaking with it but I can't get it to place the hyperlink into the cell and display text as it never gets past this point:
.Address = getAddress
The code breaks with this error message: "Run-time error '438': Object doesn't support this property or method."
I apologize if this is a rehash. Any help would be appreciated.
Option Explicit
Sub PPTableMacro()
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim strPresPath As String
Dim strExcelFilePath As String
Dim getAddress As Hyperlink
strPresPath = "C:\Somewhere...\Presentation.pptm"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 4
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table 1")
Sheets("Sheet1").Activate
Set getAddress = Sheet1.Range("F1").Hyperlinks(1)
oPPTShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(1, 1)
oPPTShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(1, 2)
oPPTShape.Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = Cells(1, 3)
oPPTShape.Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = Cells(1, 4)
oPPTShape.Table.Cell(5, 2).Shape.TextFrame.TextRange.Text = Cells(1, 5)
With oPPTShape.Table.Cell(6, 2).Shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
.Address = getAddress.Address
.TextToDisplay = "Link"
End With
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
End Sub
Edit: So I've been searching the web for anyone else who's come across this issue but so far I haven't had any luck. There's nothing else on stack overflow I could find to help, nor did I find anything on the Microsoft Developer site for Office 2010. I looked at the examples provided there for the Hyperlink.TextToDisplay ="..." attribute and it looks like I'm doing everything right. I hope its not a cheap shot to edit my question in hopes someone will see it, but I'm not sure what else to do on this one.

Resources