From a few Excel files to PowerPoint

Question

I'm totally new in VBA programming. However I have to (and want) create macro in Excel file to automatically creating PowerPoint presentation.

I hope that someone will be able to help me or have a similar problem. Namely - I have 6 columns in the Excel file:

1 - slide number
2 - file access path
3 - file name
4 - sheet name
5 - slide range
6 - slide title

I would like the macro to automatically enter a given file -> sheet -> take the slide's range, copy and paste it as a picture for the presentation and give it the appropriate title and go through the loop to the next line and do the same.

Is anyone able to help me? Below is the code that I managed to write, however, I do not know how to refer to the sheet and the range of the slide from the given cell.

Option Explicit

Sub ExcelRangeToPowerPoint()
     Dim rng As Range
     Dim PowerPointApp As Object
     Dim myPresentation As Object
     Dim mySlide As Object
     Dim myShape As Object
     Dim adr1 As String
     Dim shta As Worksheet
     Dim wrk As String

     Application.DisplayAlerts = False

     wrk = ThisWorkbook.Name ' nname
     adr1 = Worksheets("Sheet1").Range("B2")

    'Copy Range from Excel
    ' Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")

    '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

      ThisWorkbook.Activate
      Range("A2").Select
     'DO While
      Do While ActiveCell.Value <> ""
          Workbooks.Open Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True ' to be sure read-only open
          ' Worksheet Open from D2
          'Copy Range from E2

          'Add a slide to the Presentation
          Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
          'Paste to PowerPoint and position
          mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile + title from F2
          Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

          ActiveWorkbook.Close SaveChanges:=False  ' close file and don't save
          ActiveCell.Offset(1, 0).Range("A1").Select
      Loop

      MsgBox ("Ready")
      Application.CutCopyMode = False
      Application.DisplayAlerts = True
End Sub

it would be helpful, but all my data source from which I want to create some slides are in a few excel files. And that's my problem, because I do not know how to refer to sheets and ranges in other files. But thank you for a quick answer :) — AdamMalysz92
lets say you are in sheet 2 and if you want to refer from sheet 1 use =sheet1!A1 hope it helps. Use ! to refer to other sheet — NoobProgrammer
Ok, but how can i refer to some sheet and some range from another workbook (Warning! - name of this sheet and range is in column D and E) - You can look on the screen which I added. — AdamMalysz92
for the range are you intending to sum the value?? or something else(explain a little more)? if you are, try =sheet1!SUM(B2:N15) — NoobProgrammer

AdamMalysz92 AdamMalysz92 · Accepted Answer · 2018-01-18T11:32:31

Really Thanks for answer I had to use "ThisWorkbook.Activate" in a few places. And now this macro work almost perfect.. it means that the order of creating slides is reversed : 1 is the last and the last is 1.. What is more I'd like to also create Title of each slide from Excel file column F.

Below my VBA code:

Sub VBA_PowerPoint()

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim MyWb As Workbook 'variable for workbook
Dim MyWs As Worksheet 'variable for worksheet
Dim MyRg As Excel.Range ' variable for Range

Application.DisplayAlerts = False

ThisWorkbook.Activate
Range("A2").Select

'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


 'Do While
 ThisWorkbook.Activate

Do While ActiveCell.Value <> ""
 ThisWorkbook.Activate
 Set MyWb = Workbooks.Open(Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True) ' to be sure read-only open
 ' Worksheet Open from D2
 ThisWorkbook.Activate
 Set MyWs = MyWb.Worksheets(ActiveCell.Offset(0, 3).Value) 'now MyWs is referenced to the worksheet in column D

 'Copy Range from E2
' Set MyRg = MyWs.Range(ActiveCell.Offset(0, 4).Value) 'now MyWs is referenced to the worksheet in column E

' MyWs.Range(MyRg).Copy 'we copy the range shown in column E
 ThisWorkbook.Activate
 MyWs.Range(ActiveCell.Offset(0, 4).Value).Copy


 'Add a slide to the Presentation
 Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
 'Paste to PowerPoint and position
 mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile + title from F2
 Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

 'after pasting, we go back to active workbook
  Application.CutCopyMode = False
  MyWb.Activate

  MyWb.Close SaveChanges:=False  ' close file and don't save
  Set MyWs = Nothing
  Set MyWb = Nothing
  ActiveCell.Offset(1, 0).Select 'we go 1 row down
Loop


Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

From a few Excel files to PowerPoint

2 Answers