尝试将Excel图表复制到Powerpoint演示文稿时，下标超出范围错误 [英] Subscript out of range error when trying to copy Excel charts to Power Point presentation

问题描述

我试图使用函数将图表从excel复制到PPT宏的PPT宏。虽然，当我试图运行该功能，它说下标超出范围在下面显示的行，我真的很困惑为什么。

I am trying to copy charts from excel to PPT in a PPT macro using a function. Though, when I try to run the function it says "Subscript out of range" on the line indicated below and I am really confused why.

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

推荐答案

p>我认为你正在混合 Range 。请尝试下面发布的代码，其中包含与原始代码相当多的修改。我在下面详细说明主要的。您必须设置对 Microsoft Excel vvv对象库的引用。在VBE中，使用工具 - > 引用。

I think that you are mixing Ranges. Please try the code posted below, which contains quite a few modifications from your original code. I detail below the main ones. You have to set a reference to the Microsoft Excel vvv Object Library. In the VBE, use Tools -> References.

主要变化：

1. 声明 Function 中的参数类型。

将函数更改为 Sub （您只执行操作， ）。

Changed the Function to Sub (you only perform actions, you do not return a value).

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

Used NamedRange directly. There is no need for the convoluted way in which you used it. The first argument is now superfluous (you may remove it).

使用的变量引用对象。

Used variables to refer to objects. This allows for much easier coding and debugging.

删除了一些选择和激活。你不应该使用它们，除非严格需要（显然不是这样）。

Removed some of the Select and Activate. You should not use them unless strictly needed (apparently this is not the case).

点，你可以改进你的代码，特别是沿着上面设置的线。
请先试试看。如果它不工作，使用调试器，手表和即时窗口探索更深入，并提供反馈。

There are still quite a few points where you can improve your code, in particular along the lines set above. Please first try it. If it does not work, use the debugger, watches and the immediate window to explore deeper, and give feedback.

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

这篇关于尝试将Excel图表复制到Powerpoint演示文稿时，下标超出范围错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！