VBA宏创建PPT演示文稿

Question

我设置了一个宏来自动创建ppt。此外，我还设置了一个自定义集合对象来存储不同的"产品"及其各自的图表。考虑到这一点，我想在自定义集合中创建一个For Each循环，以迭代每个产品，并创建PPT演示，PPT幻灯片上的间隔为(3*i+1(。如

For I = 0 to slides.count
            ‘slides(3*i) to write to the first page
            ‘slides(3*I + 1) to write to the second page
            ‘slides(3*I + 2) to write to the third page
Next i

到目前为止，我的代码可以生成集合中的第一个项，没有问题，不幸的是，我不接受设置循环来迭代集合。

这就是我现在的位置：

理想情况下，我也想在集合中存储宽度/高度和格式的详细信息，但一次只能存储一个问题！

任何帮助都将不胜感激！！

Sub test2()
Dim Mypath As String
Dim Myname As String
Dim myTitle As String
Dim shapeCount As Integer
Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")

Myname = ThisWorkbook.Name
Mypath = ThisWorkbook.Path

PPT.Visible = True
PPT.Presentations.Open Filename:=Mypath & "XXXX - 
Template.pptx"
Dim shP As Object
Dim myShape As Object
Dim mySlide As Object
Dim tempSize As Integer, tempFont As String

Dim Funds As Collection
Dim V As Fund
Set V = New Fund
Set Funds = New Collection
Dim FundID As String
Dim Title As Range
Dim Fund_MER As String
Dim Fund_Yield As String
Dim Asset_Alloc As String
Dim Asset_Alloc2 As String
Dim Asset_Alloc3 As String
Dim Asset_Alloc4 As String
Dim Title_2 As String
Dim Trailing As String
Dim Calendar As String

V.FundID = "V1"
V.Title = "Profile_FactSheet_Title_En"
V.Fund_MER = "V1_MER"
V.Fund_Yield = "V1_Yield"
V.Asset_Alloc = "V1_assetAlloc_En_SourceData"
V.Asset_Alloc2 = "AAV1EN"
V.Asset_Alloc3 = "FIV1EN"
V.Asset_Alloc4 = "FIMAV1EN"
V.Title_2 = "Profile_FactSheet_Title_En"
V.Trailing = "RetV1TrailingEN"
V.Calendar = "RetV1CalendarEN"

Funds.Add V, V.FundID
V.FundID = "V2"
V.Title = "Profile_FactSheet_Title_En"
V.Fund_MER = "V2_MER"
V.Fund_Yield = "V2_YIELD"
V.Asset_Alloc = "V2_assetAlloc_En_SourceData"
V.Asset_Alloc2 = "AAV2EN"
V.Asset_Alloc3 = "FIV2EN"
V.Asset_Alloc4 = "EQSECV2EN"
V.Title_2 = "Profile_FactSheet_Title_En"
V.Trailing = "RetV2TrailingEN"
V.Calendar = "RetV2CalendarEN"

Funds.Add V, V.FundID
Worksheets("Profile Fact Sheet Tables EN").Activate
'select the name of report
Set shP = Range(V.Title)
'select the ppt sheet you wish to copy the object to
Set mySlide = PPT.ActivePresentation.slides(1)
'count the number of shapes currently on the PPT
shapeCount = mySlide.Shapes.Count
'copy the previously selected shape
shP.Copy
'paste it on the PPT
mySlide.Shapes.Paste
'wait until the count of shapes on the PPT increases, which signals that the past operation is finished.
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
'adjust formatting of the newly copied shape: position on the sheet, font & size
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 254.016
    myShape.Top = 42.8085
    myShape.Width = 286.0515
    myShape.Height = 46.7775
    myShape.TextEffect.FontSize = 15
    myShape.TextEffect.FontName = "Century Schoolbook"

'activate the sheet containing the charts.
Worksheets("Profile Fact Sheet Tables EN").Activate

'copy mer data object
Set shP = Range(V.Fund_MER)
'switch to slide
Set mySlide = PPT.ActivePresentation.slides(1)
'count the current number of shapes
shapeCount = mySlide.Shapes.Count
'copy and paste previously selected shape
shP.Copy
mySlide.Shapes.Paste
'wait until the number of shapes on the ppt changes.
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
'adjust the formatting of the shape.
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 210.357
    myShape.Top = 149.121
    myShape.TextEffect.FontSize = 10
    myShape.TextEffect.FontName = "Calibri (Corps)"
Set shP = Range(V.Fund_Yield)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 210.357
    myShape.Top = 164.43
    myShape.TextEffect.FontSize = 10
    myShape.TextEffect.FontName = "Calibri (Corps)"
mySlide.ActiveWindow.Selection.Unselect

Set shP = Range(V.Asset_Alloc) 'Range("V1_assetAlloc_En_SourceData")
Set mySlide = PPT.ActivePresentation.slides(1) '1
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 265.923
    myShape.Top = 124.74
    myShape.Width = 259.4025

Worksheets("Profile Fact Sheet Tables EN").Activate
Set shP = ActiveSheet.Shapes(V.Asset_Alloc2)
Set mySlide = PPT.ActivePresentation.slides(1)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount

Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 62.937
    myShape.Top = 246.3615

Worksheets("Profile Fact Sheet Tables EN").Activate
Set shP = ActiveSheet.Shapes(V.Asset_Alloc3)
Set mySlide = PPT.ActivePresentation.slides(1)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 28.0665
    myShape.Top = 450.765
Worksheets("Profile Fact Sheet Tables EN").Activate
Set shP = ActiveSheet.Shapes(V.Asset_Alloc4)
Set mySlide = PPT.ActivePresentation.slides(1)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 265.6395
    myShape.Top = 481.0995
Worksheets("Profile Fact Sheet Tables EN").Activate
Set shP = Range(V.Title_2) 'Cells(1, 2)
Set mySlide = PPT.ActivePresentation.slides(1)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount

Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 254.016
    myShape.Top = 42.8085
    myShape.Width = 286.0515
    myShape.Height = 46.7775
    myShape.TextEffect.FontSize = 15
    myShape.TextEffect.FontName = "Century Schoolbook"
Worksheets("Perf Tables 1859").Activate

Set shP = ActiveSheet.Shapes(V.Trailing)
Set mySlide = PPT.ActivePresentation.slides(2)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 33.453
    myShape.Top = 155.925
Worksheets("Perf Tables 1859").Activate
Set shP = ActiveSheet.Shapes(V.Calendar)
Set mySlide = PPT.ActivePresentation.slides(2)
shapeCount = mySlide.Shapes.Count
shP.Copy
mySlide.Shapes.Paste
Do '<~~ wait completion of paste operation
    DoEvents
Loop Until mySlide.Shapes.Count > shapeCount
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 33.453
    myShape.Top = 372.519
Next
End Sub

Answer 1

刚刚查看了您的代码。如果我理解你的问题，那么你想创建一个循环来创建这8张左右的幻灯片，然后问从哪里获得高度或宽度等参数。如果这种理解是正确的，你可以在Excel中创建一个表来管理你的自动化。这样做的好处是，如果有什么变化，就不必更改代码：您只需要更新控制表。此表可能包含以下列：

• 来源表
• 震源范围
• 目标幻灯片编号
• 目标形状宽度
• 目标形状高度
• 目标形状顶部
• 左侧目标形状
• 目标形状字体名称
• 目标形状字体大小

然后，宏需要遍历每一行并读取值，以便正确定位和格式化Powerpoint。为了保持代码的整洁和可重用性，您应该尝试将其封装在函数中，例如，一个用于复制、粘贴和设置形状的函数，该函数基于上表中提到的参数。

如果你只需要一些有效的东西，你也可以试试(我的软件(SlideFab.com，它是免费的，只要每张幻灯片从Excel复制到Powerpoint的元素不超过两个(例如形状、图表、表格等((所以我想它应该对你有效(。那么你根本不需要编码。

干杯

Jens