VBA宏创建PPT演示文稿

时间：2018-11-13 20:15:59

标签： excel vba powerpoint

我设置了一个宏来自动创建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

1 个答案:

答案 0 :(得分：0)

仅查看您的代码。如果我的问题没错，那么您想创建一个循环，创建所有这8张幻灯片，然后询问从何处获取高度或宽度之类的参数。 如果这种理解是正确的，则可以在Excel中创建一个表来管理自动化。这样做的好处是，如果发生某些更改，则无需更改任何代码：您只需要更新控制表即可。该表可能包含以下列：

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

然后，您的宏需要遍历每一行并读出值，以便正确定位和格式化Powerpoint。为了保持代码的干净和可重用，您应该尝试将其包装在函数中，例如用于根据上表中的参数复制，粘贴和设置形状的功能。

如果您只需要一些有用的东西，也可以尝试（我的软件）SlideFab.com，只要每张幻灯片不超过两个元素（例如，形状，图表，表格等）即可免费使用从Excel复制到Powerpoint（我想它应该对您有用）。然后，您根本不需要编写代码。

欢呼

詹斯

相关问题
最新问题