遍历同目录下word文件名及查找其内容

ldl---

要求在批注里，最好带注释，谢谢！！！

ahnyt

你的文档里没有要写的内容

ldl---

有的，意思是用VBA自动查出文档里的签发人：“王二狗”、供稿：“张三毛”、日期：“2017年1月3日”

ldl---

遇WORD就没法了！数量大，望有老师出手，谢谢。。。。。。。。。。。。。。。

ldl---

自己顶下，高手帮助。。。。。。。。。。。。。。。

duquancai

ldl--- 发表于 2017-9-20 11:15
自己顶下，高手帮助。。。。。。。。。。。。。。。

帮你顶。。。。。。。

182197315

Sub 从word中提取信息到excel()
    Dim mypath$, myfile$, str$, k%, arr(1 To 1000, 1 To 6)
    Dim wordApp As Object
    Dim wordD As Word.Document
    mypath = ThisWorkbook.Path & "\"
    myfile = Dir(mypath & "*.doc?")
    Set wordApp = CreateObject("word.Application")
    Do While myfile <> ""
        k = k + 1
        arr(k, 1) = Left(myfile, InStr(myfile, "."))
        arr(k, 3) = Left(arr(k, 1), InStr(arr(k, 1), "：") - 1)
        arr(k, 4) = Right(arr(k, 1), Len(arr(k, 1)) - InStr(arr(k, 1), "：") - 1)
        Set wordD = wordApp.Documents.Open(mypath & myfile)
        str = wordD.Range.Text
        arr(k, 2) = RegFind(str, "(\S+)(?=印发)")
        arr(k, 5) = RegFind(str, "似稿：([\u4e00-\u9fa5]{1,4})|供稿：([\u4e00-\u9fa5]{1,4})")
        arr(k, 6) = RegFind(str, "签发人：([\u4e00-\u9fa5]{1,4})")
        wordD.Close
        myfile = Dir
    Loop
    Range("a6").Resize(k, 6) = arr
    Set wordD = Nothing
    wordApp.Quit
End Sub
Function RegFind(strValue As String, strFind As String) As String
    Dim reg As Object, Mat As Object
    Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = strFind
    Set Mat = reg.Execute(strValue)(0)
    Set Reg= Nothing
    RegFind = Mat
End Function

182197315

楼主好粗心，给的文档里面有的是似搞（应该是拟稿吧），有的是供稿，而表头要提取拟稿。

ldl---

谢谢，虽然看不太懂，还有一个”拟稿“也打成”似稿“了！全部改成”拟稿“后，运行出错：Dim wordD As Word.Document，用户定义类型未定义？

182197315

引用Microsoft Word