使用VBA從Excel復制到打開的Powerpoint演示文稿

Question

我知道以前曾以類似的方式問過這個問題，但是我對編碼非常陌生，並且發現很難理解其他一些帖子中使用的語言。

• 本質上，任務是將一個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嗎？

Answer 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第2行到第5行循環， For i = 2 To 5 ，但是您可以通過擺脫5一直循環到最后一行數據並將其替換為WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row

最后，不要忘記通過將Object變量設置為Nothing來釋放它們。

順便說一句，我擺脫了無用的“ Select和“ Activate ，它們在大多數情況下幾乎沒有資源，它們非常貪婪。