尝试将 Excel 图表复制到 Power Point 演示文稿时出现下标超出范围错误

我正在尝试使用函数将图表从 excel 复制到 PPT 宏中的 PPT。不过，当我尝试运行该函数时，它在下面指示的行上显示“下标超出范围”，我真的很困惑为什么。

Public dlgOpen As FileDialog
Public folder As String
Public excelApp As Object
Public xlWorkBook As Object
Public xlWorkBook2 As Object
Public PPT As Presentation
Public Name1 As String
Public Name2 As String
Public rng1 As Range
Public rng2 As Range
Dim NamedRange As Range


Public Sub GenerateVisual()
    Set PPT = ActivePresentation
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = True

    Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
    xlWorkBook.Sheets("MarketSegmentTotals").Activate
    xlWorkBook.ActiveSheet.Shapes.AddChart.Select
    xlWorkBook.ActiveChart.ChartType = xlColumnClustered
    xlWorkBook.ActiveChart.SetSourceData Source:=xlWorkBook.ActiveSheet.Range("MarketSegmentTotals!$A$1:$F$2")
    xlWorkBook.ActiveChart.Legend.Delete
    xlWorkBook.ActiveChart.SetElement (msoElementChartTitleAboveChart)
    xlWorkBook.ActiveChart.SetElement (msoElementDataLabelCenter)
    xlWorkBook.ActiveChart.ChartTitle.Text = "DD Ready by Market Segment"
    xlWorkBook.ActiveSheet.ListObjects.Add

    With xlWorkBook.ActiveChart.Parent
        .Top = 100    ' reposition
        .Left = 100   ' reposition
    End With

    Set xlWorkBook2 = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\GeneralTotals.xls")
    xlWorkBook2.Sheets("Totals").Activate
    xlWorkBook2.ActiveSheet.Shapes.AddChart.Select
    xlWorkBook2.ActiveChart.ChartType = xlColumnClustered
    xlWorkBook2.ActiveChart.SetSourceData Source:=xlWorkBook2.ActiveSheet.Range("Totals!$A$1:$C$2")
    xlWorkBook2.ActiveChart.Legend.Delete
    xlWorkBook2.ActiveChart.SetElement (msoElementChartTitleAboveChart)
    xlWorkBook2.ActiveChart.SetElement (msoElementDataLabelCenter)
    xlWorkBook2.ActiveChart.ChartTitle.Text = "Total DD Ready"
    xlWorkBook2.ActiveSheet.ListObjects.Add

    With xlWorkBook2.ActiveChart.Parent
        .Top = 100    ' reposition
        .Left = 100   ' reposition
    End With

    Set rng1 = xlWorkBook.Sheets("MarketSegmentTotals").Range("B8:F25")
    Set rng2 = xlWorkBook2.Sheets("Totals").Range("A8:C25")

    Call RangeToPresentation("MarketSegmentTotals", rng1)
    Call RangeToPresentation("Totals", rng2)

    'Set dlgOpen = Application.FileDialog(Type:=msoFileDialogFolderPicker)
    '
    'dlgOpen.Show
    'dlgOpen.Title = "Select Report Location"
    '
    'folder = dlgOpen.SelectedItems(1)

End Sub


Public Function RangeToPresentation(sheetName, NamedRange)
    Dim ppApp As Object
    Dim ppPres As Object
    Dim PPSlide As Object

    Set ppApp = GetObject(, "Powerpoint.Application")

    Set ppPres = ppApp.ActivePresentation
    ppApp.ActiveWindow.ViewType = ppViewNormal

    ' Select the last (blank slide)
    longSlideCount = ppPres.Slides.Count
    ppPres.Slides(1).Select

    Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    xlWorkBook.Sheets(sheetName).Range(NamedRange.Address).CopyPicture Appearance:=xlScreen, _
        Format:=xlBitmap

    ' Paste the range
    PPSlide.Shapes.Paste.Select

    'Set the image to lock the aspect ratio
    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue

    'Set the image size slightly smaller than width of the PowerPoint Slide
    ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
    ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10

    'Shrink image if outside of slide borders
    If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
        ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
    End If

    If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
        ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
    End If

    ' Align the pasted range
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True    

    ' Clean up
    Set PPSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing

End Function

我认为你正在混合Ranges。请尝试下面发布的代码，其中包含对原始代码的相当多的修改。我在下面详细介绍了主要内容。您必须设置对Microsoft Excel vvv 对象库。在VBE中，使用Tools -> 参考.

主要变化：

1. 声明你的参数类型Function.

2. 改变了Function to Sub（您只执行操作，不返回值）。

3. Used NamedRange直接地。不需要您使用它的复杂方式。第一个参数现在是多余的（您可以将其删除）。

4. 使用变量来引用对象。这使得编码和调试变得更加容易。

5. 删除了一些Select and Activate。除非严格需要，否则不应使用它们（显然情况并非如此）。

您仍然有很多地方可以改进您的代码，特别是沿着上面设置的路线。 请先尝试一下。如果不起作用，请使用调试器、监视和立即窗口进行更深入的探索，并提供反馈。

Option Explicit

Public dlgOpen As FileDialog
Public folder As String
Public excelApp As Object
Public xlWorkBook As Excel.Workbook
Public xlWorkBook2 As Excel.Workbook
Public PPT As Presentation
Public Name1 As String
Public Name2 As String
Public rng1 As Excel.Range
Public rng2 As Excel.Range
Dim NamedRange As Excel.Range
Dim xlws As Excel.Worksheet
Dim xlsh As Excel.Shape
Dim xlch As Excel.Chart
Dim xlws2 As Excel.Worksheet
Dim xlsh2 As Excel.Shape
Dim xlch2 As Excel.Chart

Public Sub GenerateVisual()
    Set PPT = ActivePresentation
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = True

    Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
    Set xlws = xlWorkBook.Sheets("MarketSegmentTotals")
    Set xlsh = xlws.Shapes.AddChart
    Set xlch = xlsh.Chart
    With xlch
        .ChartType = xlColumnClustered
        .SetSourceData Source:=xlws.Range("$A$1:$F$2")
        .Legend.Delete
        .SetElement (msoElementChartTitleAboveChart)
        .SetElement (msoElementDataLabelCenter)
        .ChartTitle.Text = "DD Ready by Market Segment"
    End With
    xlws.ListObjects.Add

    With xlch.Parent
        .Top = 100    ' reposition
        .Left = 100   ' reposition
    End With

    Set xlWorkBook2 = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\GeneralTotals.xls")
    Set xlws2 = xlWorkBook.Sheets("Totals")
    'xlWorkBook2.Sheets("Totals").Activate
    Set xlsh2 = xlws2.Shapes.AddChart
    Set xlch2 = xlsh2.Chart
    With xlch2
        .ChartType = xlColumnClustered
        .SetSourceData Source:=xlws2.Range("$A$1:$C$2")
        .Legend.Delete
        .SetElement (msoElementChartTitleAboveChart)
        .SetElement (msoElementDataLabelCenter)
        .ChartTitle.Text = "Total DD Ready"
    End With
    xlWorkBook2.ActiveSheet.ListObjects.Add

    With xlws2.Parent
        .Top = 100    ' reposition
        .Left = 100   ' reposition
    End With

    Set rng1 = xlws.Range("B8:F25")
    Set rng2 = xlws2.Range("A8:C25")

    Call RangeToPresentation("MarketSegmentTotals", rng1)
    Call RangeToPresentation("Totals", rng2)

    'Set dlgOpen = Application.FileDialog(Type:=msoFileDialogFolderPicker)
    '
    'dlgOpen.Show
    'dlgOpen.Title = "Select Report Location"
    '
    'folder = dlgOpen.SelectedItems(1)

End Sub


Public Sub RangeToPresentation(ByVal sheetName As String, NamedRange As Excel.Range)
    Dim ppApp As Object
    Dim ppPres As Object
    Dim PPSlide As Object
    Set ppApp = GetObject(, "Powerpoint.Application")
    Set ppPres = ppApp.ActivePresentation
    ppApp.ActiveWindow.ViewType = ppViewNormal

    ' Select the last (blank slide)
    Dim longSlideCount As Integer
    longSlideCount = ppPres.Slides.Count
    ppPres.Slides(1).Select    
    Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    NamedRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

    ' Paste the range
    PPSlide.Shapes.Paste.Select

    'Set the image to lock the aspect ratio
    ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue

    'Set the image size slightly smaller than width of the PowerPoint Slide
    ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
    ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10

    'Shrink image if outside of slide borders
    If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
        ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
    End If
    If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
        ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
    End If

    ' Align the pasted range
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing

End Sub