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

发布网友 发布时间：2022-04-24 08:06

我来回答

共3个回答

热心网友 时间：2022-05-03 11:14

如何从多个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

提示找不到工程库，

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

热心网友 时间：2022-05-03 12:32

热心网友 时间：2022-05-03 14:07