将表格从Excel复制到PowerPoint VBA

我正在尝试使用VBA将表格从Excel工作表复制并粘贴到PowerPoint幻灯片中，并保留其源格式[]。 我想在粘贴后直接在幻灯片上写故事。除了形状没有粘贴到桌子上之外，一切似乎都很好

Sub CreatePP()
    Dim ppapp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppTextBox As PowerPoint.Shape
    Dim iLastRowReport As Integer
    Dim sh As Object
    Dim templatePath As String

        On Error Resume Next
        Set ppapp = GetObject(, "PowerPoint.Application")
        On Error GoTo 0

    'Let's create a new PowerPoint
        If ppapp Is Nothing Then
            Set ppapp = New PowerPoint.Application
        End If
    'Make a presentation in PowerPoint
        If ppapp.Presentations.Count = 0 Then
           Set ppPres = ppapp.Presentations.Add
           ppPres.ApplyTemplate "C:\Users\luunt1\AppData\Roaming\Microsoft\Templates\Document Themes\themevpb.thmx"
        End If

    'Show the PowerPoint
        ppapp.Visible = True

         For Each sh In ThisWorkbook.Sheets
         If sh.Name Like "E_KRI" Then
            ppapp.ActivePresentation.Slides.Add ppapp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            ppapp.ActiveWindow.View.GotoSlide ppapp.ActivePresentation.Slides.Count
            Set ppSlide = ppapp.ActivePresentation.Slides(ppapp.ActivePresentation.Slides.Count)
            ppSlide.Select


            iLastRowReport = Range("B" & Rows.Count).End(xlUp).Row
            Range("A1:J" & iLastRowReport).Copy
            DoEvents
            ppapp.CommandBars.ExecuteMso ("PasteExcelTableSourceFormatting")
            Wait 3
            With ppapp.ActiveWindow.Selection.ShapeRange
              .Width = 700
              .Left = 10
              .Top = 75
              .ZOrder msoSendToBack
            End With
            Selection.Font.Size = 12
          'On Error GoTo NoFileSelected
            AppActivate ("Microsoft PowerPoint")
            Set ppSlide = Nothing
            Set ppapp = Nothing
    End If
    Next   
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

---

与其选择表格的范围并粘贴，还不如解决粘贴表格对象本身的问题，因此：

ActiveSheet.ListObjects(1).Copy  'Assuming it is the only table on the sheet.  Adjust this code as needed for your specific case

---

与其选择表格的范围并粘贴，还不如解决粘贴表格对象本身的问题，因此：

ActiveSheet.ListObjects(1).Copy  'Assuming it is the only table on the sheet.  Adjust this code as needed for your specific case

---

那些椭圆形是手动放在excel表格上的吗？是的。你有办法解决吗？请帮助我如果它们是手动放置的（未链接到单元格），那么解决方案将不容易。您需要在对象之间循环，找到它们的位置，然后确定powerpoint工作表上的相对位置以放置它们。这些椭圆形是手动放置在excel工作表上的吗？是的。你有办法解决吗？请帮助我如果它们是手动放置的（未链接到单元格），那么解决方案将不容易。您需要循环浏览对象，找到它们的位置，然后确定powerpoint页面上的相对位置以将它们放置在那里