求助：批量提取word文档中内容

alai1222

各位老师，请教下怎样提取一个文件夹下word的第一行，第二行，第三行内容到excel表格，如下图，谢谢

alai1222

谢谢各位老师请指点迷津

shenjianrong163

代码放Excel中：

1. Sub test()
   
2.     Dim i%, j%, k%, f$, FileName$, wd, arr(1 To 10000, 1 To 4)
   
3.     Set wd = CreateObject("Word.Application")
   
4.     f = ThisWorkbook.Path
   
5.     FileName = Dir(f & "\*.doc*")
   
6.     k = 0
   
7.     Do While FileName <> ""
   
8.         With wd.Documents.Open(f & "" & FileName)
   
9.             k = k + 1
   
10.             arr(k, 1) = Left(FileName, InStrRev(FileName, ".") - 1)
    
11.             arr(k, 2) = Replace(.Paragraphs(1).Range.Text, Chr(13), "")
    
12.             arr(k, 3) = Replace(.Paragraphs(2).Range.Text, Chr(13), "")
    
13.             arr(k, 4) = "考生得分" & Split(Replace(.Paragraphs(3).Range.Text, Chr(13), ""), "考生得分")(1)
    
14.             .Close False
    
15.         End With
    
16.         
    
17.         FileName = Dir
    
18.     Loop
    
19.     wd.Quit
    
20.     Set wd = Nothing
    
21.     If k = 0 Then MsgBox "没有数据!": Exit Sub
    
22.     With Sheets("Sheet1")
    
23.         .Range("A2:D" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1).ClearContents
    
24.         .[A2].Resize(k, 4) = arr
    
25.     End With
    
26.     MsgBox "汇总完成!"
    
27. End Sub

复制代码

shenjianrong163

附件供参考：


求助模拟批量提取word内容.rar (27.37 KB, 下载次数: 34)

2021-3-10 21:53 上传

点击文件名下载附件

alai1222

shenjianrong163 发表于 2021-3-10 21:53
附件供参考：

谢谢高手帮忙，点赞评分送花