如何从一千多个Word中提取信息到Excel里？

Question

一千多分作业，想要提取其中的发文部门和发文时间制作成表格。文档格式均相同，都包含：发文部分：xxx 发布时间：xxx需要通过编程实现吗？

Answer 1

如何从多个WORD文件中提取相应的文字和数值到EXCEL里

WORD文件是一个报告，里面是各人的信息，如何把多个文件中的姓名、电话、身份证号码、家庭地址这些信息提取到EXCL里面，以便于统计分析。因为文件太多了，希望大家可以帮忙给个效率点的办法！先谢谢大家了！

大体结构是这样的，可以参照以下：    

Sub 汇总()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Cells.Borders.LineStyle = xlNone
Application.ScreenUpdating = False
Dim wordD As Word.Document
Dim wordapp As Object
Dim cPath$, cFile$, i%, arr()
cPath = ThisWorkbook.Path & "\"
cFile = Dir(cPath & "*.doc?")
Set wordapp = CreateObject("word.Application")
Do While cFile <> ""
Set wordD = wordapp.Documents.Open(cPath & cFile)
i = i + 1
ReDim Preserve arr(1 To 4, 1 To i)
With wordD.tables(4)
arr(1, i) = Trim(Replace(Replace(.Cell(2, 1).Range.Text, Chr(7), ""), Chr(13), ""))
arr(3, i) = Trim(Replace(Replace(.Cell(2, 3).Range.Text, Chr(7), ""), Chr(13), ""))
End With
With wordD
arr(2, i) = Trim(Replace(Replace(.tables(3).Cell(2, 4).Range.Text, Chr(7), ""), Chr(13), ""))
arr(4, i) = Trim(Replace(Replace(.tables(5).Cell(2, 2).Range.Text, Chr(7), ""), Chr(13), ""))
End With
wordD.Close
cFile = Dir
Loop
Set wordD = Nothing
wordapp.Quit
Range("a2").Resize(i, 4).Value = Application.Transpose(arr)
Range("A1:D" & i + 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub

大神，如果中间夹杂几个格式不一样的doc，会报错停止，数据不会保存，可以不可以自动跳过那些提取不出来的？

程序里加一句代码
On Error Resume Next

Sub 提取信息()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Cells.Borders.LineStyle = xlNone
Application.ScreenUpdating = False
Dim wordD As Word.Document
Dim wordapp As Object
Dim cPath$, cFile$, i%, arr()
cPath = ThisWorkbook.Path & "\"
cFile = Dir(cPath & "*.doc?")
Set wordapp = CreateObject("word.Application")
Do While cFile <> ""
Set wordD = wordapp.Documents.Open(cPath & cFile)
i = i + 1
ReDim Preserve arr(1 To 4, 1 To i)
With wordD
arr(1, i) = Replace(Replace(.Paragraphs(18).Range.Text, Chr(7), ""), Chr(13), "")
arr(3, i) = Replace(Replace(.Paragraphs(20).Range.Text, Chr(7), ""), Chr(13), "")
arr(2, i) = Replace(Replace(.Paragraphs(44).Range.Text, Chr(7), ""), Chr(13), "")
arr(4, i) = Replace(Replace(.Paragraphs(82).Range.Text, Chr(7), ""), Chr(13), "")
End With
wordD.Close
cFile = Dir
Loop
Set wordD = Nothing
wordapp.Quit
Range("a2").Resize(i, 4).Value = Application.Transpose(arr)
Range("A1:D" & i + 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
End Sub

提示找不到工程库，

请看图片，请引用以下选项。

Answer 2

将所有需要整理的表格放在一个文件夹里面
打开word或金山文字，本文使用金山系列软件（支持国产正版一下），点击插入菜单，然后依次点击“对象"-"文件中文字"
选择需要插入的表格
使用快捷键ctrl+A,全选。然后点击工具栏中表格工具-表格转成文本。转换标记符号可以选逗号，也可选其他不常见的符号，如@，！等，但一定不能与现在文件中的符号重复。
打开查找替换工具，将所有的段落标记和空格替换为空（删除所有回车符和空格）
继续替换，将表格的表头文字（本文为”招聘人员报名表“）替换为段落标记（回车符）。然后另存为文本文件（后缀名txt），保存选项默认即可。

打开金山表格，准备导入。点击数据菜单中”导入数据“，依次点击”直接打开数据文件“-”选择数据源“，选择刚才保存的文本文件，然后下一步。
选择”分隔符号“，然后选择逗号或者刚才金山文字表格转换为文本中设定的分隔符号，下一步，继续下一步，直到完成导入。如果有身份证号、银行账号等超过15位的数据，导入时点击该列，选择文本格式，日期也要选择对应格式。否则默认即可。
导入工作结束，整理表格即可。删除不需要的数据列，给每列添加列名。

Answer 3

是从一千多个word文件中提取，还是从一个word文件中的一千多个记录提取。
如果从一千多个word文件中提取，最好把文件名统一命名，然后编程实现。
如果是从一个文件里提取一千多个记录，可以通过复制，粘贴，转置。

追问

朋友，是一千多个文件中
我要是会编程我就不来这问了（文科生的暴风哭泣），谢谢