如何批量把Word每段文字作为PPT每页的备注文字？

古豆

Word 中有4个（不定，但和PPT中幻灯片页数相同）段落，也有空段，PPT中有4页（不定，但和Word段数相同），如何用VBA读取Word每一段文字插入到PPT的每一页备注上？（每页插入前先清除原备注文字）


以下为附件，谢谢大佬指点……
Word每段文字作为PPT每页的备注文字.zip (39.64 KB, 下载次数: 25)

2020-11-11 12:27 上传

点击文件名下载附件

古豆

求PowrPoint大佬帮助

shenjianrong163

1. Sub test()
   
2.     '每页插入WORD对应段落作为备注
   
3.     With Application.FileDialog(msoFileDialogFilePicker)
   
4.         Dim vrtSelectedItem As Variant
   
5.         .Filters.Clear
   
6.         .Filters.Add "Word文件", "*.doc*"
   
7.         .AllowMultiSelect = False
   
8.         If .Show = -1 Then MyPath$ = .SelectedItems(1) Else Exit Sub
   
9.     End With
   
10.     Dim i%, j%, p%, wdApp, arr()
    
11.     Set wdApp = CreateObject("Word.Application")
    
12.     p = ActivePresentation.Slides.Count
    
13.     With wdApp.Documents.Open(MyPath)
    
14.         wdApp.Visible = False
    
15.         For i = 1 To .Paragraphs.Count
    
16.             ReDim Preserve arr(1 To i)
    
17.             arr(i) = Replace(.Paragraphs(i).Range.Text, Chr(13), "")
    
18.         Next
    
19.         .Close False
    
20.     End With
    
21.     wdApp.Quit
    
22.     Set wdApp = Nothing
    
23.     If UBound(arr) < p Then MsgBox "Word中段落总数与PPT的张数不相等，请重新调整!": Exit Sub
    
24.     For i = 1 To p
    
25.         ActivePresentation.Slides.Item(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text = arr(i)
    
26.     Next
    
27.     MsgBox "处理完成!"
    
28. End Sub

复制代码

shenjianrong163

附件供参考：



Word每段文字作为PPT每页的备注文字.rar (46.03 KB, 下载次数: 37)

2021-1-27 14:04 上传

点击文件名下载附件

古豆

shenjianrong163 发表于 2021-1-27 14:05
附件供参考：

太好用了！感谢 shenjianrong163 大佬！！！

没想这次遇到贵人啦～～～