Excel读取Word Table元素

 1 Option Explicit
 2 
 3 Sub Mian()
 4 Application.ScreenUpdating = False
 5 Application.DisplayAlerts = False
 6 Application.EnableEvents = False
 7 Application.StatusBar = True
 8 Dim Path$, File$, WordApp, Dic, Br(1 To 10000, 1 To 14)
 9     Path = ThisWorkbook.Path & ""
10     File = Dir(Path & "学生学籍卡.doc*")
11     Set Dic = Data()
12     Set WordApp = CreateObject("Word.Application")
13     WordApp.Visible = False
14     Dim Table, Doc, RKey, Ckey, K&, KK&, eTable
15 
16     '=遍历Word的table
17     Set Doc = WordApp.Documents.Open(Path & File)
18     For Each Table In Doc.Tables
19     K = K + 1
20         With Table
21         '读取子table
22          Set eTable = Table.cell(10, 2).Tables(1)
23          Br(K, 9) = Replace(eTable.cell(2, 2).Range.Text, "", "")
24          Br(K, 10) = Replace(eTable.cell(2, 3).Range.Text, "", "")
25          Br(K, 11) = Replace(eTable.cell(3, 2).Range.Text, "", "")
26          Br(K, 12) = Replace(eTable.cell(3, 3).Range.Text, "", "")
27         KK = 0
28         '读取Table
29             For Each RKey In Dic.keys
30                 For Each Ckey In Dic(RKey).keys
31                 KK = KK + 1
32                     Br(K, KK) = Replace(.cell(RKey, Ckey).Range.Text, "", "")
33                     If KK = 8 Then KK = KK + 4
34                 Next
35             Next
36         End With
37     Next
38     Doc.Close
39     WordApp.Visible = True
40     WordApp.Quit
41     Set WordApp = Nothing
42     Range("a2").Resize(K, 14) = Br
43     MsgBox "读取数据成功"
44     Application.StatusBar = False
45     Application.EnableEvents = True
46     Application.ScreenUpdating = True
47     Application.DisplayAlerts = True
48 End Sub
49 
50 
51 Private Function Data()
52 Dim Ar, Dic, I&, J&
53     Ar = Sheets("取数规则").Range("a1").CurrentRegion
54     Set Dic = CreateObject("Scripting.Dictionary")
55     For I = 2 To UBound(Ar)
56     Set Dic(Ar(I, 1)) = CreateObject("Scripting.Dictionary")
57         For J = 2 To UBound(Ar, 2)
58             If Ar(I, J) <> "" Then
59                 Dic(Ar(I, 1))(Ar(I, J)) = True
60             End If
61         Next J
62     Next
63     Set Data = Dic
64 End Function