1
Excelシートからシェイプで構成されたテーブルをコピーし、VBAを使用してPowerPointスライドに貼り付けようとしています。ソースフォーマット[]を保持しています。 貼り付けた後にスライドの物語に直接書きたいと思います。形状がテーブル[
]に貼り付けられなかった以外は、すべてうまくいくようです。ExcelテーブルからExcelテーブルへのコピー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
を手動で配置したものを楕円形のものですシートを凌ぐ? – RGA
はい、そうです。それを解決する方法はありますか?助けてください –
手動で配置されている、つまりセルにリンクされていない場合、ソリューションは簡単なものにはなりません。あなたは、オブジェクトを循環してその位置を見つけ、そこに置くためにパワーポイントシート上の相対位置を決定する必要があります – RGA