使用VBA从Excel复制到打开的Powerpoint演示文稿

时间：2015-07-07 11:04:21

标签： excel vba excel-vba

我知道此问题之前已经以类似方式提出过，但我对编码很新，并且发现很难理解其他一些帖子中使用的语言。

  • 基本上，任务是将一行数据从一个Excel电子表格复制到另一个excel电子表格中，从而创建该单行的图表。

  • 它总共创建了6个图表，这些图表都需要复制到powerpoint演示文稿中，其中4个是幻灯片，另外2个是下一个。

  • 然后代码应循环回到开头并再次开始流程，但下一行数据将此迭代的结果粘贴到2个新幻灯片。

我已经设法编写了足够的代码来从excel中获取数据将其转换为图表，然后将其导出到powerpoint，但它总是复制到新的powerpoint演示而不是新的幻灯片，我需要将其复制到活动状态介绍。这是代码：

    Sub Tranposer()
    '
    ' Tranposer Macro
    ' Copies and Transposes answers to the graph calculator
    '
    ' Keyboard Shortcut: Ctrl+h
    '
        Windows("Data Spreadsheet.xlsx").Activate
        Rows("2:2").Select
        Selection.Copy
        Windows("Graph Spreadsheet.xlsm").Activate
        Range("B1").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

    Dim PowerPointApp As PowerPoint.Application
    Dim myPresentation As PowerPoint.Presentation
    Dim mySlide As PowerPoint.Slide
    Dim myShapeRange As PowerPoint.Shape



    'Create an Instance of PowerPoint
      On Error Resume Next

        'Is PowerPoint already opened?
          Set PPApp = GetObject(, "Powerpoint.Application")
          Set PPPres = PPApp.ActivePresentation

          Set PowerPointApp = GetObject(class:="PowerPoint.Application")

        'Clear the error between errors
          Err.Clear

        'If PowerPoint is not already open then open PowerPoint
          If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

        '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.Visible = True
      PowerPointApp.Activate

    'Create a New Presentation
      Set myPresentation = PowerPointApp.Presentations.Add

    'Add a slide to the Presentation
      Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)

    'Copy Excel Range
    ActiveSheet.ChartObjects("Chart 1").Activate
      ActiveChart.ChartArea.Copy

    'Paste to PowerPoint and position
      mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

   'Copy Excel Range
    ActiveSheet.ChartObjects("Chart 7").Activate
      ActiveChart.ChartArea.Copy

    'Paste to PowerPoint and position
      mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    ActiveSheet.ChartObjects("Chart 5").Activate
      ActiveChart.ChartArea.Copy

    'Paste to PowerPoint and position
      mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

   'Copy Excel Range
    ActiveSheet.ChartObjects("Chart 4").Activate
  ActiveChart.ChartArea.Copy

    'Paste to PowerPoint and position
      mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    ActiveSheet.ChartObjects("Chart 6").Activate
      ActiveChart.ChartArea.Copy

    'Paste to PowerPoint and position
      mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    ActiveSheet.ChartObjects("Chart 9").Activate
      ActiveChart.ChartArea.Copy

    'Paste to PowerPoint and position
      mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    'Clear The Clipboard
      Application.CutCopyMode = False

    End Sub

我知道这是很多代码，我知道我可以在图表中循环节省时间，但我不知道如何循环，所以我现在很乐意离开它是怎么回事。任何人都可以帮助我出口到powerpoint吗？

1 个答案:

答案 0 :(得分：1)

如果我理解得很好，您想循环选择Data Spreadsheet中的下一行，将其复制/粘贴到Graph Spreadsheet中，然后粘贴每行的6个图表（在2张幻灯片上）进入相同的演示文稿。

以下是您审核的代码（代码下方的修改/选项）：

Sub Tranposer()
'
' Tranposer Macro
' Copies and Transposes answers to the graph calculator
'
' Keyboard Shortcut: Ctrl+h
'
Dim PowerPointApp As PowerPoint.Application, _
    myPresentation As PowerPoint.Presentation, _
    mySlide As PowerPoint.Slide, _
    myShapeRange As PowerPoint.Shape, _
    WsData As Worksheet, _
    WsGraph As Worksheet

Set WsData = Workbooks("Data Spreadsheet.xlsx").ActiveSheet
Set WsGraph = Workbooks("Graph Spreadsheet.xlsm").ActiveSheet

On Error Resume Next
'Is PowerPoint already opened?
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'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.Visible = True
PowerPointApp.Activate


'Create a New Presentation
'Set myPresentation = PowerPointApp.Presentations.Add
'Or Open an EXISTING one
Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx")


'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count, ppLayoutTitleOnly)


For i = 2 To 5      'WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row
    WsData.Rows(i & ":" & i).Copy
    WsGraph.Range("B1").PasteSpecial Paste:=xlPasteAll, _
                                    Operation:=xlNone, _
                                    SkipBlanks:=False, _
                                    Transpose:=True
    'Copy Excel Range
    WsGraph.ChartObjects("Chart 1").ChartArea.Copy
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    WsGraph.ChartObjects("Chart 7").ChartArea.Copy
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    WsGraph.ChartObjects("Chart 5").ChartArea.Copy
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    WsGraph.ChartObjects("Chart 4").ChartArea.Copy
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile


    'Add a new slide
    Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count, ppLayoutTitleOnly)


    'Copy Excel Range
    WsGraph.ChartObjects("Chart 6").ChartArea.Copy
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    'Copy Excel Range
    WsGraph.ChartObjects("Chart 9").ChartArea.Copy
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Next i



'Clear The Clipboard
Application.CutCopyMode = False

'Set = Nothing : Free named Object-variables
Set PPApp = Nothing
Set PPPres = Nothing
Set PowerPointApp = Nothing
Set myPresentation = Nothing
Set mySlide = Nothing
Set WsData = Nothing
Set WsGraph = Nothing

End Sub

首先，您需要在此处Set WsData = Workbooks("Data Spreadsheet.xlsx").ActiveSheet指定工作表的名称，例如Set WsData = Workbooks("Data Spreadsheet.xlsx").Sheets("Sheet_Name")。

然后，您可以使用Set myPresentation = PowerPointApp.Presentations.Add创建新演示文稿，也可以使用Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx")打开现有演示文稿。

对于循环，目前它被设置为在Data Spreadsheet中使用For i = 2 To 5从第2行循环到第5行，但是您可以循环到最后一行数据摆脱5并将其替换为WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row

最后，不要忘记通过将其设置为Nothing来释放您的对象变量。

顺便说一下，我摆脱了无用的Select和Activate，它们在资源上非常贪婪，大部分时间几乎都没有。

相关问题
最新问题