求助大神，批量提取word特定内容到excel

游牧旅程

求助大神，现有多个word文档，如何批量提取特定内容到excel？？

游牧旅程

182197315

论坛里好多例子

qcw911

一般来说用正则的方法提取

182197315

Sub ReadFromWord()
    Dim oWordApp As Object, oDoc As Object, txt$
    Dim myPath$, MyName$, k%, Result(1 To 10000, 1 To 8)
   
    On Error Resume Next
    Range("A2:H10000").ClearContents
    myPath = ThisWorkbook.Path & "\"
    MyName = Dir(myPath & "*.doc?")
    Set oWordApp = CreateObject("Word.Application")

    Do While MyName <> ""
            Set oDoc = GetObject(myPath & MyName)
            txt = oDoc.Range.Text
            oDoc.Close True
            
            k = k + 1
            Result(k, 1) = Split(MyName, ".")(0)
            Result(k, 2) = RegxFind(txt, "姓名(\S*)\s")
            Result(k, 3) = RegxFind(txt, "身份证号(\d*)\D")
            Result(k, 4) = RegxFind(txt, "手机号码(\d+)")
            Result(k, 5) = RegxFind(txt, "性别(\S*)\s")
            Result(k, 6) = RegxFind(txt, "年龄(\S*)\s")
            Result(k, 7) = RegxFind(txt, "生日(\S*)\s")
            Result(k, 8) = RegxFind(txt, "身份证所在地(\S*)\s")
            
         MyName = Dir
    Loop
    Range("A2").Resize(k, 8) = Result
    Set oWordApp = Nothing
End Sub

Function RegxFind(strValue As String, strFind As String) As String
    Dim RegX As Object, objMatchs As Object
    Dim strTemp As String
   
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Pattern = strFind
   
    Set objMatchs = RegX.Execute(strValue)
    strTemp = objMatchs(0).SubMatches(0)
   
    Set RegX = Nothing
    RegxFind = strTemp
End Function

182197315

这是附件，可测试。

游牧旅程

182197315 发表于 2019-10-18 21:38
这是附件，可测试。

感谢大佬！！！