excel中A列单元格内容转为PPT每页标题如何解决？

ym1080

想excel中A列单元格内容转为PPT每页标题
网上找到下面宏
是选定了当前sheet的A列，然后把这一列内容拷贝到ppt中，
每一个单元格值做ppt的一页中的一个标题

但是
Set ptSld = ptPre.Slides.Add(Index:=ptPre.Slides.Count + 1, Layout:=ppLayoutBlank)
到这句就出错了   后面不知道还有没有错
请各位老师指导修改一下


Sub test()

Dim ptApp As Object
Set ptApp = CreateObject("PowerPoint.Application")
Dim ptPre As Object
Set ptPre = ptApp.Presentations.Add
Dim ptSld As Object
Dim ptShape As Object
ptApp.Visible = msoTrue

ActiveSheet.Names.Add Name:="NewWord", RefersTo:="=OFFSET($A$1,0,0,COUNTA($A:$A))"
Set R = ActiveSheet.Names("NewWord").RefersToRange
dd = R.Count - 1

For rr = 2 To dd + 1
Set ptSld = ptPre.Slides.Add(Index:=ptPre.Slides.Count + 1, Layout:=ppLayoutBlank)
Set ptShape = ptSld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=10, Top:=17, Width:=700, Height:=50)
With ptShape.TextFrame
.TextRange.Text = R(rr)
.TextRange.Font.Name = "楷体_GB2312"
.TextRange.Font.Size = 30
.TextRange.Font.Color.RGB = RGB(Red:=0, Green:=0, Blue:=255)
.TextRange.Font.Bold = True
End With

Set ptShape = ptSld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=10, Top:=80, Width:=700, Height:=450)

With ptShape.TextFrame
.TextRange.Text = "This is for test!"
.TextRange.Font.Name = "楷体_GB2312"
.TextRange.Font.Size = 25
End With

ptSld.Shapes(2).TextFrame.TextRange.Characters.Font.Color = vbBlack
Next rr
End Sub

ym1080

excel中A列单元格内容转为PPT每页标题

shenjianrong163

1. Sub test()
   
2.     Dim ptApp As Object
   
3.     Set ptApp = CreateObject("PowerPoint.Application")
   
4.     Dim ptPre As Object
   
5.     Set ptPre = ptApp.Presentations.Add
   
6.     Dim ptSld As Object
   
7.     Dim ptShape As Object
   
8.     ptApp.Visible = msoTrue
   
9.     ActiveSheet.Names.Add Name:="NewWord", RefersTo:="=OFFSET($A$1,0,0,COUNTA($A:$A))"
   
10.     Set R = ActiveSheet.Names("NewWord").RefersToRange
    
11.     dd = R.Count - 1
    
12.     For rr = 1 To dd
    
13.         Set ptSld = ptPre.Slides.Add(ptPre.Slides.Count + 1, 12)
    
14.         Set ptShape = ptSld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
    
15.         Left:=10, Top:=17, Width:=700, Height:=50)
    
16.         With ptShape.TextFrame
    
17.             .TextRange.Text = R(rr)
    
18.             .TextRange.Font.Name = "楷体_GB2312"
    
19.             .TextRange.Font.Size = 30
    
20.             .TextRange.Font.Color.RGB = RGB(Red:=0, Green:=0, Blue:=255)
    
21.             .TextRange.Font.Bold = True
    
22.         End With
    
23.         Set ptShape = ptSld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
    
24.         Left:=10, Top:=80, Width:=700, Height:=450)
    
25.         With ptShape.TextFrame
    
26.             .TextRange.Text = "This is for test!"
    
27.             .TextRange.Font.Name = "楷体_GB2312"
    
28.             .TextRange.Font.Size = 25
    
29.         End With
    
30.         ptSld.Shapes(2).TextFrame.TextRange.Characters.Font.Color = vbBlack
    
31.     Next rr
    
32. End Sub

复制代码

ym1080

shenjianrong163 发表于 2021-3-11 16:00

果然厉害   谢谢老师

还有  请教老师
下面文本栏显示This is for test!
能否  和标题栏一样  从B列提取内容 那样就更完美了

shenjianrong163

ym1080 发表于 2021-3-11 21:23
果然厉害   谢谢老师

还有  请教老师

先在B列中添加内容，代码如下：

1. Sub test()
   
2.     Dim ptApp As Object
   
3.     Set ptApp = CreateObject("PowerPoint.Application")
   
4.     Dim ptPre As Object
   
5.     Set ptPre = ptApp.Presentations.Add
   
6.     Dim ptSld As Object
   
7.     Dim ptShape As Object
   
8.     Dim i&, arr
   
9.     ptApp.Visible = msoTrue
   
10.     With Sheets("Sheet1")
    
11.         arr = .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    
12.     End With
    
13.     For i = 1 To UBound(arr)
    
14.         Set ptSld = ptPre.Slides.Add(ptPre.Slides.Count + 1, 12)
    
15.         Set ptShape = ptSld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
    
16.         Left:=10, Top:=17, Width:=700, Height:=50)
    
17.         With ptShape.TextFrame
    
18.             .TextRange.Text = arr(i, 1)
    
19.             .TextRange.Font.Name = "楷体_GB2312"
    
20.             .TextRange.Font.Size = 30
    
21.             .TextRange.Font.Color.RGB = RGB(Red:=0, Green:=0, Blue:=255)
    
22.             .TextRange.Font.Bold = True
    
23.         End With
    
24.         Set ptShape = ptSld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
    
25.         Left:=10, Top:=80, Width:=700, Height:=450)
    
26.         With ptShape.TextFrame
    
27.             .TextRange.Text = arr(i, 2)
    
28.             .TextRange.Font.Name = "楷体_GB2312"
    
29.             .TextRange.Font.Size = 25
    
30.         End With
    
31.         ptSld.Shapes(2).TextFrame.TextRange.Characters.Font.Color = vbBlack
    
32.     Next
    
33. End Sub

复制代码

ym1080

shenjianrong163 发表于 2021-3-11 22:13
先在B列中添加内容，代码如下：

完美   谢谢指教
祝万事如意！