[英]Copy table from Excel to PowerPoint VBA
我正在嘗試將包含Excel表格形狀的表格復制並粘貼到PowerPoint幻燈片中,使用VBA保持其源格式[ ]。 我想在粘貼后直接寫在幻燈片上的故事。 一切似乎工作正常,除了形狀沒有粘貼到表[
]。
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.