Can't get the Excel VBA to copy PPT files - vba

I have the following code, I attempted to modify it so it loops through a list in excel, opens each ppt file in the list and copies that to a new ppt file. But it is getting hung up and has an error during the loop.
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i, j As Integer
Dim pres1, new_pres As PowerPoint.Presentation
Dim oslide, s, oSld As PowerPoint.Slide
Dim oShape, oSh, oshp As PowerPoint.Shape
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
For i = 1 To 1 ' LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides.shapes(j).Copy
new_pres.Slides.Paste
new_pres.Application.CommandBars.ExecuteMso "PasteSourceFormatting")
Next j
pres1.Close
Set pres1 = Nothing
Next I
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub

I got it to work, it was the PasteSourceFormatting that I needed when running from powerpoint that wasn't needed when converting to excel. This pulls every file from the list, opens, copies to a master powerpoint with formatting intact, and closes. in the end I have a new master powerpoint that has all of the presentations that are on the list
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
Application.CutCopyMode = False
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i As Integer, j As Integer
Dim pres1 As PowerPoint.Presentation, new_pres As PowerPoint.Presentation
Dim oslide As PowerPoint.Slide, s As PowerPoint.Slide, oSld As PowerPoint.Slide
Dim oShape As PowerPoint.Shape, oSh As PowerPoint.Shape, oshp As PowerPoint.Shape
Dim PPShape As Object
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
k = 1
For i = 1 To LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides(j).Copy
new_pres.Slides.Paste
' new_pres.Slides.Paste
' new_pres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
k = k + 1
Next j
pres1.Close
Set pres1 = Nothing
Next i
For Each oSld In new_pres.Slides
oSld.HeadersFooters.Clear
oSld.HeadersFooters.SlideNumber.Visible = msoFalse
oSld.HeadersFooters.DateAndTime.Visible = msoFalse
Next oSld
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 700, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.InsertSlideNumber
End With
'ActivePresentation.PageSetup.FirstSlideNumber = 0
new_pres.Slides(1).DisplayMasterShapes = msoTrue
Set oshp = Nothing
response = MsgBox(prompt:="Is this For Official Use Only?", Buttons:=vbYesNo)
If response = vbYes Then
txt = "For Official Use Only"
' If statement to check if the yes button was selected.
Else
' The no button was selected.
MsgBox "Then it is assumed this is a Boeing Proprietary presentation"
txt = "Boeing Proprietary"
End If
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 300, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = txt
End With
injdate = InputBox("Please enter the date for the Stand Up")
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = injdate
End With
Application.CutCopyMode = True
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub

Related

Export queries from Access-Form to Excel with Loop in VBA

I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub

Select ALL shapes on a powerpoint slide, and get all data back to Excel VBA to eventually change the text of those shapes

Below is a code that allows you to select a shape, then it populates cells in Excel by giving shape name, content, slide number, and commentary (for your personal notes). BUT instead of selecting one shape at a time, I would like to select ALL or more than one shape at a time to populate back to the Excel sheet.
Can anyone help?
Here is the code:
Dim ppapp As PowerPoint.Application
Dim pppres As PowerPoint.Presentation
Sub getshapedata()
On Error GoTo line1
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
Dim shapeslide
Dim shapename
Dim shapetext
Dim nextrow
shapeslide = ppapp.ActiveWindow.View.Slide.SlideIndex
shapename = ppapp.ActiveWindow.Selection.ShapeRange(1).Name
shapetext = pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")
nextrow = Sheet1.Range("a" & Rows.Count).End(xlUp).Row + 1
Sheet1.Range("a" & nextrow) = shapeslide
Sheet1.Range("b" & nextrow) = shapename
Sheet1.Range("c" & nextrow) = shapetext
Sheet1.Range("d" & nextrow) = friendlyname
Exit Sub
line1:
MsgBox "No item selected"
End Sub
Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
For Each c In Sheet1.Range("a2:a" & Sheet1.Range("a" & Rows.Count).End(xlUp).Row)
shapeslide = Sheet1.Range("a" & c.Row)
shapename = Sheet1.Range("b" & c.Row)
shapetext = Sheet1.Range("c" & c.Row).Text
friendlyname = Sheet1.Range("d" & c.Row)
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
Next c
End Sub
Declare a Slide variable and a Shape variable to use as an iterator:
Dim ppSlide as Object 'PowerPoint.Slide
Dim ppShape as Object 'PowerPoint.Shape
Then set it to your slide:
Set ppSlide = ppapp.ActiveWindow.View.Slide
Then, iterate over the shapes collection on that slide:
For each pptShape in ppSlide.Shapes
If ppShape.HasTextFrame Then
'### DO STUFF
End If
Next
In your code, something like below, as amended with the custom function GetPPTSelection, based on the comment:
I don't want ALL the shapes to write back to excel, only the ones I select. How do I go about doing that?
The function GetPPTSelection returns a Collection of shapes (if any are selected) and I think it should handled "Grouped" shapes, as well as multiple selections, and also ignores shapes which don't have a TextFrame (embedded images, etc.)
Sub getshapedata()
Dim ppSlide As Object 'PowerPoint.Slide
Dim ppShape As Object 'PowerPoint.Shape
Dim nextrow As Long
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
Set ppSlide = ppapp.ActiveWindow.View.Slide
For each ppShape in GetPPTSelection(ppPres.Windows(1))
friendlyname = InputBox("Insert Friendly Name for " & shapetext, "Friendly Name", "")
With Sheet1
nextrow = .Range("a" & .Rows.Count).End(xlUp).Row + 1
.Range("a" & nextrow) = ppSlide.SlideIndex
.Range("b" & nextrow) = ppShape.Name
.Range("c" & nextrow) = ppShape.TextEffect.Text
.Range("d" & nextrow) = friendlyname
End With
Next
Exit Sub
Function GetPPTSelection(window As Object)
' Returns a Collection of selected shapes, if shapes are selected
' Returns a Nothing, if anything else (slides, text, etc.) selected
Dim coll As New Collection
Dim c As Integer
Dim s As Integer
Dim g As Integer
Dim sel As Object '# PowerPoint.Selection
Const ppSelectionShapes As Long = 2 ' in case of late binding
Set sel = window.Selection
If sel.Type = ppSelectionShapes Then
For s = 1 To sel.ShapeRange.Count
If IsGrouped(sel.ShapeRange(s)) Then
'# handle grouped shapes
For g = 1 To sel.ShapeRange(s).GroupItems.Count
coll.Add sel.ShapeRange(s).GroupItems(g)
Next
Else:
'# ordinary, ungrouped shapes:
coll.Add sel.ShapeRange(s)
End If
Next
End If
'# Get rid of any shapes which don't have a textframe:
For c = coll.Count To 1 Step -1
If Not coll(c).HasTextFrame Then coll.Remove (c)
Next
'# Return the collection to the calling procedure:
Set GetPPTSelection = coll
End Function
Function IsGrouped(shp As Object)
'Returns boolean if shape is groupshapes
Dim ret As Boolean
On Error Resume Next
ret = shp.GroupItems.Count > 1
IsGrouped = ret
End Function
I got rid of the On Error GoTo Line1 because there is no label Line1 in this code, also, I think it's generally better to anticipate and trap errors, rather than using a catchall like that which tends to make debugging real problems that much more difficult. If this code is still raising some errors, let me know which line and I can try to help debug it.
Or, just use On Error Resume Next at your own peril :)

Copy data from Excel to powerpoint with vba

I have created a code with vba which copy data from excel sheet and paste the same as picture in powerpoint slide, but its not working exactly as per my need.
It should copy data from each worksheets and paste it in a given powerpoint slide worksheet wise. Measn worksheet 1 data should be copied in slide 1 followed by worksheet 2 data in slide 2 and so on and at the end it should save the created ppt file.
But my code is copying and pasting all worksheets data overlaping each other in all the slides of the powerpoint.
Since i am new to vba i am not sure where i am going wrong with the below code:
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim MyTitle As String
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select Application.Wait(Now + TimeValue("0:00:1"))
xlwksht.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 65
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
xlwksht.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
oPPTApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 250
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 7.2
oPPTApp.ActiveWindow.Selection.ShapeRange.Width = 400
Next xlwksht
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
Please give this a shot. The main change is that I removed the For Each loop. You are already looping through the slides of the deck and can use the slide number to reference the Excel worksheet (they are numbered, as well). It was creating a mess, now it runs smoothly.
Sub WorkbooktoPowerPoint()
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyRange1 As String 'Define another Range
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim oSlide As Slide
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "C:\Users\FYI\PPT1.pptx"
strNewPresPath = "C:\Users\FYI\new1.pptx"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
For Each oSlide In oPPTFile.Slides
i = oSlide.SlideNumber
' The following line was added after the OPs follow-up
If i > ActiveWorkbook.Sheets.Count Then Exit For
oSlide.Select
MyRange = "B2:B5"
MyRange1 = "B8:B11"
With ActiveWorkbook.Sheets(i)
.Range(MyRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
.ActiveWindow.Selection.ShapeRange.Top = 65
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
.Range(MyRange1).CopyPicture Appearance:=xlScreen, Format:=xlPicture
oSlide.Shapes.Paste.Select
With oPPTApp
.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True
.ActiveWindow.Selection.ShapeRange.Top = 250
.ActiveWindow.Selection.ShapeRange.Left = 7.2
.ActiveWindow.Selection.ShapeRange.Width = 400
End With
End With
Next
oPPTApp.Activate
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub

Unable to copy data from Excel to PPT using Macro

I have a macro that basically is supposed to copy ranges from excel spreadsheets and then paste them into a powerpoint file. So one excel sheet per slide.
Here is my macro so far:
Option Explicit
Sub ExportToPPT()
Dim PPAPP As PowerPoint.Application
Dim PPRES As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim ppSRng As PowerPoint.ShapeRange
Dim XLAPP As Excel.Application
Dim XLwbk As Excel.Workbook
Dim xlWst As Excel.Worksheet
Dim XLRng As Excel.Range
Dim ppPathFile As String
Dim ppNewPathFile
Dim chartNum As Integer
Dim maxCharts As Integer
Debug.Print vbCrLf & " ---- EXPORT EXCEL RANGES POWERPOINT ----"
Debug.Print Now() & " - Exporting ranges to .ppt"
'CHANGE WHEN ADDING CHARTS - MUST ALSO ADD SLIDE to .PPT and change loop
Dim chartRng(1 To 9) As Excel.Range
Dim SlideNum As Integer
Dim SlideOffset As Integer
Set XLwbk = Excel.ActiveWorkbook
Set xlWst = XLwbk.Sheets("Test1")
'This accounts for the title slide and any others before the automatedpaste
SlideOffset = 1
Set chartRng(1) = XLwbk.Sheets("Test1").Range("A1:B15")
Set chartRng(2) = XLwbk.Sheets("Test2").Range("A1:E33")
Set chartRng(3) = XLwbk.Sheets("Test3").Range("A1:E33")
Set chartRng(4) = XLwbk.Sheets("Test4").Range("A1:E4")
Set chartRng(5) = XLwbk.Sheets("Test5").Range("A1:J14")
Set chartRng(6) = XLwbk.Sheets("Test6").Range("A1:I33")
Set chartRng(7) = XLwbk.Sheets("Test7").Range("A1:I11")
Set chartRng(8) = XLwbk.Sheets("Test8").Range("A1:I8")
' Create instance of PowerPoint
Set PPAPP = CreateObject("Powerpoint.Application")
PPAPP.Visible = True
' Open the presentation (Same folder as the Excel file)
ppPathFile = ActiveWorkbook.Path + "TestPPT.pptx"
Debug.Print ppPathFile
Set PPRES = PPAPP.Presentations.Open(ppPathFile)
PPAPP.ActiveWindow.ViewType = ppViewSlide
chartNum = 1
'Loop through all chart ranges
'CHANGE WHEN ADDING CHARTS
For chartNum = 1 To 9
SlideNum = chartNum + SlideOffset
Debug.Print "Chart number " & chartNum & " to slide number " & SlideNum
' Copy the range as a picture
chartRng(chartNum).CopyPicture Appearance:=xlScreen, Format:=xlPicture
'PowerPoint operations
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _ **//New code**
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))
Debug.Print PPSlide.Name
PPSlide.Select
PPAPP.ActiveWindow.ViewType = ppViewSlide
'ppapp.ActivePresentation.Slides.
' Paste the range
'PPAPP.ActiveWindow.View.Slide (SlideNum)
PPAPP.ActiveWindow.View.Paste
'PPSlide.Shapes.Paste
'PPSlide.Shapes(0).Select
'PPSlide.Shapes.Paste.Select
' Align the pasted range
Set ppSRng = PPAPP.ActiveWindow.Selection.ShapeRange
With ppSRng
.LockAspectRatio = msoTrue
If (.Width / .Height) > 1.65 Then
.Width = 650
Else
.Height = 400
End If
End With
With ppSRng
'.Width = 650
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.IncrementTop 1.5
End With
Next chartNum
PPAPP.ActivePresentation.Slides(1).Select
PPAPP.ActiveWindow.ViewType = ppViewNormal
PPAPP.Activate
ppNewPathFile = ActiveWorkbook.Path & "\Test\TestPPT.pptx" & Format(Now(), "yyyymmdd_hhmmss")
PPAPP.ActivePresentation.SaveAs ppNewPathFile, ppSaveAsDefault
Debug.Print Now() & " - Finished"
End Sub
When I run the Macro it opens PowerPoint but stops and I get the following Error:
And when I debug it stops at this line:
Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum)
Any help on how to fix this would be great guys.
The error points to a counting problem that you've introduced in your code. Apparently, during the first iteration, it attempts to choose the second slide of a one-slide presentation (the second slide does not exist) and throwing an error.
I would assume this occurs because of your SlideOffset variable. Consider first adding a slide using before running Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum). Something like this:
Set pptLayout = PPAPP.ActivePresentation.Slides(1).CustomLayout
Set pptSlide = PPAPP.ActivePresentation.Slides.AddSlide(2, pptLayout)
Try using this
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))

EXcel VBA : Excel Macro to create table in a PowerPoint

My requirement is I have a Excel which contains some data. I would like to select some data from the excel and open a PowerPoint file and
Create Table in PowerPoint and populate the data in to it
Right now I have succeeded in collecting the data from excel opening a PowerPoint file through Excel VBA Code.
Code for Opening the PowerPoint from Excel.
Set objPPT = CreateObject("Powerpoint.application")
objPPT.Visible = True
Dim file As String
file = "C:\Heavyhitters_new.ppt"
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Open(file)
Now how do I create the table in PowerPoint from Excel and populate the data.
Timely help will be very much appreciated.
Thanks in advance,
Here's some code from http://mahipalreddy.com/vba.htm
''# Code by Mahipal Padigela
''# Open Microsoft Powerpoint,Choose/Insert a Table type Slide(No.4), then double click to add a...
''# ...Table(3 Cols & 2 Rows) then rename the Table to "Table1", Save and Close the Presentation
''# Open Microsoft Excel, add some test data to Sheet1(This example assumes that you have some data in...
''# ... Rows 1,2 and Columns 1,2,3)
''# Open VBA editor(Alt+F11),Insert a Module and Paste the following code in to the code window
''# Reference 'Microsoft Powerpoint Object Library' (VBA IDE-->tools-->references)
''# Change "strPresPath" with full path of the Powerpoint Presentation created earlier.
''# Change "strNewPresPath" to where you want to save the new Presnetation to be created later
''# Close VB Editor and run this Macro from Excel window(Alt+F8)
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Sub PPTableMacro()
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "H:\PowerPoint\Presentation1.ppt"
strNewPresPath = "H:\PowerPoint\new1.ppt"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 1
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table1")
Sheets("Sheet1").Activate
oPPTShape.Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = Cells(1, 1).Text
oPPTShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(1, 2).Text
oPPTShape.Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = Cells(1, 3).Text
oPPTShape.Table.Cell(2, 1).Shape.TextFrame.TextRange.Text = Cells(2, 1).Text
oPPTShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(2, 2).Text
oPPTShape.Table.Cell(2, 3).Shape.TextFrame.TextRange.Text = Cells(2, 3).Text
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
This Excel-VBA exports the selected range from Excel to a PowerPoint native table. It also works with merged cells.
Sub Export_Range()
Dim pp As New PowerPoint.Application
Dim ppt As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shpTable As PowerPoint.Shape
Dim i As Long, j As Long
Dim rng As Excel.Range
Dim sht As Excel.Worksheet
Set rng = Selection
pp.Visible = True
If pp.Presentations.Count = 0 Then
Set ppt = pp.Presentations.Add
Else
Set ppt = pp.ActivePresentation
End If
Set sld = ppt.Slides.Add(1, ppLayoutTitleOnly)
Set shpTable = sld.Shapes.AddTable(rng.Rows.Count, rng.Columns.Count)
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
shpTable.Table.Cell(i, j).Shape.TextFrame.TextRange.Text = _
rng.Cells(i, j).Text
Next
Next
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
If (rng.Cells(i, j).MergeArea.Cells.Count > 1) And _
(rng.Cells(i, j).Text <> "") Then
shpTable.Table.Cell(i, j).Merge _
shpTable.Table.Cell(i + rng.Cells(i, j).MergeArea.Rows.Count - 1, _
j + rng.Cells(i, j).MergeArea.Columns.Count - 1)
End If
Next
Next
sld.Shapes.Title.TextFrame.TextRange.Text = _
rng.Worksheet.Name & " - " & rng.Address
End Sub