Excel to PowerPoint

Question

我正在尝试从Excel准备演示文稿。到目前为止，VBA代码正在根据循环运行的次数来准备“ n个”表示。我希望代码仅将1张演示文稿与所有幻灯片组合在一起。运行第一个宏“ 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

我正在尝试从Excel准备演示文稿。到目前为止，VBA代码正在根据循环运行的次数来准备“ n个”表示。我希望代码仅生成1张带有所有幻灯片的演示文稿...

Answer 1

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