批量提取word指定内容到Excel中

Jupiterss

工作需要整理一批Word文档（如图一），提取图中框选数据到Excel（图二）中，在论坛上找到一位大神的正则表达式程序（原贴），自己改了一下。
因为是刚接触vba的纯小白，有很多知识不明白，想求助各位老师！！

ps：本来想联系原作者，因等级限制，在原贴下留言了，不知能否看到。

图一：要提取的文档

图二：提取到的表格

Jupiterss

经过几天的调整，最后结果如下：

1. Sub ReadFromWord()
   
2.     Dim oWordApp As Object, oDoc As Object, txt$
   
3.     Dim myPath$, MyName$, k%, Result(1 To 2000, 1 To 12)
   
4.    
   
5.     'On Error Resume Next
   
6.     With Sheet1
   
7.         .UsedRange.Offset(1).ClearContents
   
8.         myPath = ThisWorkbook.Path & ""
   
9.         MyName = Dir(myPath & "*.doc*")
   
10.         Set oWordApp = CreateObject("Word.Application")
    
11.    
    
12.         Do While MyName <> ""
    
13.             If InStr(MyName, "项目") > 0 Then
    
14.                 Set oDoc = GetObject(myPath & MyName)
    
15.                 txt = oDoc.Range.Text
    
16.                 txt = txt & vbLf & Chr(13)
    
17.                 txt = Replace(txt, "：", ":")
    
18.                 oDoc.Close False
    
19.                
    
20.                 k = k + 1
    
21.                 Result(k, 1) = k
    
22.                 Result(k, 2) = RegxFind(txt, "(.+?)\s", 0) '机构名称
    
23.                 Result(k, 3) = RegxFind(txt, "成立时间:(.*?)\s", 0) '成立时间
    
24.                 Result(k, 4) = RegxFind(txt, "资本类型:(.*?)\s", 0) '资本类型
    
25.                 Result(k, 5) = RegxFind(txt, "[资本性质|机构性质]:(.*?)\s", 0) '资本性质
    
26.                 Result(k, 6) = RegxFind(txt, "投资阶段:(.*?)\s", 0) '投资阶段
    
27.                 Result(k, 7) = RegxFind(txt, "(.*)资本类型：?", 0) '关注赛道
    
28.                 Result(k, 8) = RegxFind(txt, "[机构总部|注册地点]:(.*?)\s", 0) '总部
    
29.                 Result(k, 9) = RegxFind(txt, "联系电话:(.*?)\s", 0) '联系电话
    
30.                 Result(k, 10) = RegxFind(txt, "BP投递.*?:(.*?)\s", 0) 'BP邮箱地址
    
31.                 Result(k, 11) = RegxFind(txt, "官方网站:(.*?)\s", 0) '官网
    
32.                 Result(k, 12) = RegxFind(txt, "地址:(.*?)\s", 0) '地址
    
33.             End If
    
34.             MyName = Dir
    
35.         Loop
    
36.         If k > 0 Then
    
37.             .Range("A2").Resize(k, 12) = Result
    
38.         End If
    
39.         Set oWordApp = Nothing
    
40.     End With
    
41.     MsgBox "完成"
    
42. End Sub
    
43. 
    
44. Function RegxFind(strValue As String, strFind As String, Num As Integer) As String
    
45.     Dim RegX As Object, objMatchs As Object
    
46.     Dim strTemp As String
    
47.    
    
48.     Set RegX = CreateObject("vbscript.regexp")
    
49.     RegX.Pattern = strFind
    
50.    
    
51.     Set objMatchs = RegX.Execute(strValue)
    
52.     If objMatchs.Count > 0 Then
    
53.         strTemp = objMatchs(0).SubMatches(Num)
    
54.     End If
    
55.    
    
56.     Set RegX = Nothing
    
57.     RegxFind = strTemp
    
58. End Function

复制代码

分享出来，给以后有类似需求的人一点点帮助。
最后，非常感谢期间给以指导的各位老师！

于箱长

最近word问题突然火起来了

Jupiterss

于箱长 发表于 2021-11-6 15:27
最近word问题突然火起来了

感谢回复
可能最近Word的需求多了，感觉Excel比Word好处理，Word的内容比较散

于箱长

Jupiterss 发表于 2021-11-6 15:44
感谢回复
可能最近Word的需求多了，感觉Excel比Word好处理，Word的内容比较散

你找找蓝版给别人的回复，蓝版昨天刚写了一个差不多的

jiangxiaoyun

投资领域不好搞，其他都很简单，就是个查找的问题。

Jupiterss

jiangxiaoyun 发表于 2021-11-6 15:58
投资领域不好搞，其他都很简单，就是个查找的问题。

是啊，领域那个我感觉没戏，不好搞，其他的还能想到
可否指点一下，非常感谢！

Jupiterss

于箱长 发表于 2021-11-6 15:48
你找找蓝版给别人的回复，蓝版昨天刚写了一个差不多的

https://club.excelhome.net/forum.php?mod=viewthread&tid=1559369是这个吗？相似但是不太一样~

liulang0808

调整了下，楼主看看吧

Jupiterss

liulang0808 发表于 2021-11-7 09:07
调整了下，楼主看看吧

感谢大佬赐教！学习了！

andysky

视频教材：
https://mp.weixin.qq.com/s/FkxF8-cY0sDrRNRqwxoIwg


这个是通用的，不会因为WORD文件格式变化就要重写代码
可以试试