当试图将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 

Answer 1

我认为你是混合Range s。 请尝试下面的代码，其中包含您的原始代码相当多的修改。 我在下面主要的细节。 您必须设置对Microsoft Excel vvv对象库的引用。 在VBE中，使用工具 – > 参考 。

主要变化：

1. 在Function声明参数的types。

2. 将Function更改为Sub （仅执行操作，不返回值）。

3. 直接使用NamedRange 。 没有必要使用它的复杂的方式。 第一个参数现在是多余的（你可以删除它）。

4. 使用variables来引用对象。 这使编码和debugging更容易。

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

还有很多地方你可以改进你的代码，尤其是按照上面的设置。 请先尝试一下。 如果不起作用，请使用debugging器，手表和即时窗口进行深入探索，并提供反馈。

 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