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

时间：2015-01-14 19:17:40

标签： excel vba excel-vba charts powerpoint

我正在尝试使用函数将图表从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

1 个答案:

答案 0 :(得分：1)

我认为你正在混合Range。请尝试下面发布的代码，其中包含原始代码的一些修改。我在下面详细介绍了主要的。您必须设置对 Microsoft Excel vvv对象库的引用。在VBE中，使用工具 - ＆gt; 参考

主要变化：

  1. 在Function。

    2. 中声明了参数类型

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

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

  4. 使用变量来引用对象。这样可以更容易地编码和调试。

  5. 删除了部分Select和Activate。除非严格要求，否则不应使用它们（显然情况并非如此）。

    6. 还有很多方面可以改进您的代码，特别是沿着上面的设置。 请先试试吧。如果它不起作用，请使用调试器，监视器和即时窗口进行更深入的探索，并提供反馈。

    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
相关问题
最新问题