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

182197315

引用以下几项

ldl---

还是运行出错。

ldl---

再顶，哪位老师帮测试下。。。。。。。。。。。。

ldl---

重发附件：

乐乐2006201505

稍微修改了一下，完全和你的一样。
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, ".") - 1)
         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), "："))
         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, 5) = Right(arr(k, 5), Len(arr(k, 5)) - InStr(arr(k, 5), "："))
         arr(k, 6) = RegFind(str, "签发人：([\u4e00-\u9fa5]{1,4})")
         arr(k, 6) = Right(arr(k, 6), Len(arr(k, 6)) - InStr(arr(k, 6), "："))
         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

ldl---

乐乐2006201505 发表于 2017-9-27 20:56
稍微修改了一下，完全和你的一样。
Sub 从word中提取信息到excel()
     Dim mypath$, myfile$, str$, k% ...

谢谢楼上，我和你的office版本不同？我的是2010，如何解决？

乐乐2006201505

换为你的，你的应该是12.0

将你12楼的最后一个选项重新引用后试试。我这边完全通过。没出现你说的自动化问题。

ldl---

我用office2007和2010都试了。还是丢失那个16的，可能你的是2010以上的版本吧？