问将文件夹中的Excel文件转换(或复制)为相应的PowerPoint演示文稿的VBA代码

EN

Option Explicit
Sub ExcelRangeToPowerPoint()

Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape

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

'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

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)

    'Set position:
      myShapeRange.Left = 150
      myShapeRange.Top = 186

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub