Excel to PowerPoint

Question

我正在准备Excel的演示文稿。到目前为止，VBA代码正在准备"n个数“演示文稿，这是”no of times循环“运行的结果。我希望代码只生成一个与所有幻灯片合并的演示文稿。运行第一个宏"Addnumber“，运行宏"ExcelRangeToPowerPoint”。它的宏“ExcelRangeToPowerPoint”需要为宏"Addnumber“的每一个循环添加幻灯片

请支持

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

每次在Set myPresentation = PowerPointApp.Presentations.Add中调用ExcelRangeToPowerPoint()时，您都要创建一个新的演示文稿。

您可以尝试在ExcelRangeToPowerPoint()之外打开/关闭演示文稿，并向函数(如ExcelRangeToPowerPoint(myPresentationObject) )添加一个参数，然后您可以简单地在那里添加幻灯片。

或

您在粗AddNumber()的ExcelRangeToPowerPoint()中调用函数，您需要在那里循环.

例如：

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