【求助】如何把wor的中的名字一次性复制到ppt不同的幻灯片里？

yudahai1979

各位高手和大佬，在线求助，如何把wor的中的名字一次性复制到ppt不同的幻灯片里？
例如word里面的名字，如何直接导入到ppt里面不同的幻灯片里面，也就是假如word里面有20个名字，一次性把20个名字导入到20张幻灯片里面，而不需要一个一个的张贴进去？

附件： 例子.rar (51.79 KB, 下载次数: 4)

2020-3-4 13:26 上传

点击文件名下载附件

yudahai1979

天哪。大侠和高手在哪里？

乐乐2006201505

设置大纲级别后，用Word自带功能转化。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr()
   
4.   Dim pptApp As PowerPoint.Application
   
5.   Dim pptPre As PowerPoint.Presentation
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   m = 0
   
9.   With ThisDocument
   
10.     For i = 1 To .Paragraphs.Count
    
11.       m = m + 1
    
12.       ReDim Preserve arr(1 To m)
    
13.       arr(m) = Replace(.Paragraphs(i).Range.Text, Chr(13), "")
    
14.     Next
    
15.   End With
    
16.   
    
17.   mypath = ThisDocument.Path & ""
    
18.   myname = "1.pptx"
    
19.   If Dir(mypath & myname) = "" Then
    
20.     MsgBox mypath & myname & "不存在！"
    
21.     Exit Sub
    
22.   End If
    
23.   
    
24.   Set pptApp = New PowerPoint.Application
    
25.   pptApp.Visible = msoTrue
    
26.   Set pptPre = pptApp.Presentations.Add
    
27.   With pptPre
    
28.     For k = .Slides.Count To 1 Step -1
    
29.       .Slides(k).Delete
    
30.     Next
    
31.     For k = 1 To UBound(arr)
    
32.       With .Slides.Add(Index:=.Slides.Count + 1, Layout:=ppLayoutTitle)
    
33.         With .Shapes("Title 1")
    
34.           With .TextFrame
    
35.             With .TextRange
    
36.               .Text = arr(k)
    
37.               With .Font
    
38.                 .Name = "黑体"
    
39.                 .Size = 120
    
40.                 .Bold = True
    
41.               End With
    
42.               .ParagraphFormat.Alignment = ppAlignCenter
    
43.             End With
    
44.           End With
    
45.         End With
    
46.       End With
    
47.     Next
    
48.     .SaveAs FileName = ThisDocument.Path & "\结果"
    
49.     .Close
    
50.   End With
    
51.   pptApp.Quit
    
52.   Set pptPre = Nothing
    
53.   Set pptApp = Nothing
    
54.   Application.ScreenUpdating = True
    
55.   MsgBox "幻片生成完毕！"
    
56. End Sub
    
57. 
    

复制代码

chxw68

详见附件。

vvw123

褚老师高！让我看来了原来可以这样做的！