Excel to PowerPoint - excel

Question

I am trying to prepare a presentation from Excel. As of now VBA code is preparing "n number of "presentations as per no of times Loop runs. I want Code to generate just 1 presentation with all slides combined. Fist Macro "Addnumber" is run, which run Macro "ExcelRangeToPowerPoint". Its Macro "ExcelRangeToPowerPoint"which need to add slides for every loop of Macro "Addnumber"
Please Support
Sub AddNumber()
Dim Ws As Worksheet
Dim rngSel As Range
Dim rng As Range
Dim Num As Double
Dim i As Long
Dim j As Long
Dim lAreas As Long
Dim lRows As Long
Dim lCols As Long
Dim Arr() As Variant
Set rngSel = Worksheets("Sheet1").Range("A5:A30")
Do Until Range("A30") = Range("A3")
Num = 26
For Each rng In rngSel.Areas
If rng.Count = 1 Then
rng = rng + Num
Else
lRows = rng.Rows.Count
lCols = rng.Columns.Count
Arr = rng
For i = 1 To lRows
For j = 1 To lCols
Arr(i, j) = Arr(i, j) + Num
Next j
Next i
rng.Value = Arr
End If
Call ExcelRangeToPowerPoint
Next rng
Loop
End Sub
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim rng2 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mySize As PageSetup
Dim Addtitle As Shape
Dim DateT As String
'Copy Range from Excel
Set rng = Worksheets("Sheet1").Range("E2:M30")
Set rng2 = Worksheets("Sheet1").Range("F2")
Set rng3 = Worksheets("Sheet1").Range("B3")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
'11 = ppLayoutTitleOnly
'Change Theme and Layout
mySlide.ApplyTheme "C:\Users\davinder.sond\AppData\Roaming\Microsoft\Templates\Document Themes\DefaultTheme.thmx"
myPresentation.PageSetup.SlideSize = 3
myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = rng2
myPresentation.Slides(1).Shapes.Title.Left = 59
myPresentation.Slides(1).Shapes.Title.Top = 10
myPresentation.Slides(1).Shapes.Title.Height = 30
myPresentation.Slides(1).Shapes.Title.Width = 673
With myPresentation.Slides(1).Shapes.Title
With .TextFrame.TextRange.Font
.Size = 24
.Name = "Arial"
.Bold = True
.Color.RGB = RGB(255, 255, 255)
End With
End With
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.LockAspectRatio = 0
myShape.Left = 12
myShape.Top = 55
myShape.Height = 475
myShape.Width = 756
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
DateT = Format("h:mm:ss")
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 & ".pptm"
PowerPointApp.Quit
End Sub

Answer 1

You are creating a new presentation everytime you call Set myPresentation = PowerPointApp.Presentations.Add within ExcelRangeToPowerPoint().
You can either try to open/close the Presentation outside of ExcelRangeToPowerPoint() and add a parameter to the function like ExcelRangeToPowerPoint(myPresentationObject) then you can simple add the slides there
or
you call the function AddNumber() within ExcelRangeToPowerPoint() of coarse the you need to loop there...
e.g.
Sub ExcelRangeToPowerPoint()
' some preparative code
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
For Each rng in rngSel.Areas
'Filling the presentation one slide at a time
AddSlide(rng)
Next
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 &
".pptm"
PowerPointApp.Quit
'some more code
End Sub