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

Jupiterss

andysky 发表于 2021-11-7 09:42
视频教材：
https://mp.weixin.qq.com/s/FkxF8-cY0sDrRNRqwxoIwg

好的，感谢大侠分享！

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

复制代码

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

Jupiterss

分享学习过程找的资料：

作者：奇乐编程学院

cai2532

程序代码不错，收藏备用了。