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

Death123

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

182197315

可以办到，但是你得把你需要提取的信息在word里面标出来方便别人写代码啊

182197315

大体结构是这样的，可以参照以下：
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吗？

小花鹿

多个DOC的结构是不是一样的？

duquancai

你附件只有一个word文档，没看见有多个word文档！，也不知道你需要提取哪些信息？

LMY123

关注一下w to e

Death123

小花鹿 发表于 2016-11-30 21:06
多个DOC的结构是不是一样的？

结构是一样的

Death123

小花鹿 发表于 2016-11-30 21:05
文件太多，是指多个DOC吗？

多个DOC，需要导入excel，DOC的结构是一样的

Death123

182197315 发表于 2016-11-30 20:40
大体结构是这样的，可以参照以下：
Sub 汇总()
    Range("A1").CurrentRegion.Offset(1, 0).ClearConten ...

提示用户未定义，怎么搞