如何提取WORD中的特定内容制成excel表格？-提取信息excel,excel中提取另一张表格信息

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

WORD文件是一个报告，里面是各人的信息，如何把多7a686964616fe58685e5aeb9336个文件中的姓名、电话、身份证号码、家庭地址这些信息提取到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

提示找不到工程库，

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

用宏命令。
Sub abc()
Dim App, WrdDoc, Mypath As String, StrA As String, StrB As String
Mypath = ThisWorkbook.Path & "\aaa.doc" '请修改实际储存路径！
Set App = CreateObject("Word.Application") '用Set关键字创建Word应用成序对象！
App.Visible = True'根据实际情况修改是否可见
Set WrdDoc = App.Documents.Open(Mypath) '打开这个Word文件！
StrA = WrdDoc.Tables(1).Cell(1, 2).Range.Text ' 你要的第一个内容：第一行，第二列e799bee5baa6e4b893e5b19e333
StrB = WrdDoc.Tables(1).Cell(2, 2).Range.Text ' 你要的第一个内容：第二行，第二列
WrdDoc.Close ' 关闭文件
Set App = Nothing
Debug.Print StrA
Debug.Print StrB
End Sub
直接选中，复制，粘贴就行；
office办公套件之间可以随便怎样用的。甚至有很多功能都可以借用，虽然套件的功能各有侧重。

提取WORD中特定内容制成excel表格：
用宏命zd令。
Sub abc()
Dim App, WrdDoc, Mypath As String, StrA As String, StrB As String
Mypath = ThisWorkbook.Path & "\aaa.doc" '请修改实际储存路径！
Set App = CreateObject("Word.Application") '用Set关键字创建Word应用成序对象！
App.Visible = True'根据实际情况修改是否可见
Set WrdDoc = App.Documents.Open(Mypath) '打开这个Word文件版！
StrA = WrdDoc.Tables(1).Cell(1, 2).Range.Text ' 你要的第一个内容：第一行，权第二列
StrB = WrdDoc.Tables(1).Cell(2, 2).Range.Text ' 你要的第一个内容：第二行，第二列
WrdDoc.Close ' 关闭文件
Set App = Nothing
Debug.Print StrA
Debug.Print StrB
End Sub