☰

如何在 VBA 中为 Excel 的每个范围制作 PowerPoint 幻灯片

tag-icon • tag-icon vba
如何在 VBA 中为 Excel 的每个范围制作 PowerPoint 幻灯片

如何根据 Excel 范围 A2:B2 制作 PowerPoint 幻灯片。Excel 行 A1 至 A10 的所有字符（国家名称）都可制作成 PowerPoint 幻灯片。

这是我在 Excel 宏中的代码，但我收到数组错误。

 Sub PasteMultipleSlides()
 Dim myPresentation As Object
 Dim mySlide As Object
 Dim PowerPointApp As Object
 Dim shp As Object
 Dim MySlideArray As Variant
 Dim MyRangeArray As Variant
 Dim x As Long

 On Error Resume Next


 Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
 Err.Clear

 'If PowerPoint is not already open then Exit
  If PowerPointApp Is Nothing Then
   MsgBox "PowerPoint Presentation is not open, aborting."
    Exit Sub
    End If

   '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.ActiveWindow.Panes(2).Activate

         'Create a New Presentation
         Set myPresentation = PowerPointApp.ActivePresentation

     'List of PPT Slides to Paste to
      MySlideArray = Array(2, 3, 4, 5, 6)

    'List of Excel Ranges to Copy from
     MyRangeArray = Array(Sheet1.Range("A2:B10"))

     'Loop through Array data
     For x = LBound(MySlideArray) To UBound(MySlideArray)
     'Copy Excel Range
     MyRangeArray(x).Copy

     'Paste to PowerPoint and position
     On Error Resume Next
      Set shp =      myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
 On Error GoTo 0

 'Center Object
  With myPresentation.PageSetup
    shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
    shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
  End With

 Next x

 'Transfer Complete
 Application.CutCopyMode = False
 ThisWorkbook.Activate
 MsgBox "Complete!"

End Sub

答案1

您可能有多个错误，但看起来您应该改变创建 MyRangeArray 的方式。

将其声明为未分配数组

Dim MyRangeArray() As Variant

无需使用 Array 函数通过 Array() 进行转换

MyRangeArray = Range("A1:A10")

现在，MyRangeArray 的尺寸自动为MyRangeArray(1 to 10, 1 To 1)

相关内容