如何根据 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)