Excel读取Word Table元素

Option Explicit

Sub Mian()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.StatusBar = True
Dim Path$, File$, WordApp, Dic, Br(1 To 10000, 1 To 14)
    Path = ThisWorkbook.Path & ""
    File = Dir(Path & "学生学籍卡.doc*")
    Set Dic = Data()
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    Dim Table, Doc, RKey, Ckey, K&, KK&, eTable

    '=遍历Word的table
    Set Doc = WordApp.Documents.Open(Path & File)
    For Each Table In Doc.Tables
    K = K + 1
        With Table
        '读取子table
         Set eTable = Table.cell(10, 2).Tables(1)
         Br(K, 9) = Replace(eTable.cell(2, 2).Range.Text, "", "")
         Br(K, 10) = Replace(eTable.cell(2, 3).Range.Text, "", "")
         Br(K, 11) = Replace(eTable.cell(3, 2).Range.Text, "", "")
         Br(K, 12) = Replace(eTable.cell(3, 3).Range.Text, "", "")
        KK = 0
        '读取Table
            For Each RKey In Dic.keys
                For Each Ckey In Dic(RKey).keys
                KK = KK + 1
                    Br(K, KK) = Replace(.cell(RKey, Ckey).Range.Text, "", "")
                    If KK = 8 Then KK = KK + 4
                Next
            Next
        End With
    Next
    Doc.Close
    WordApp.Visible = True
    WordApp.Quit
    Set WordApp = Nothing
    Range("a2").Resize(K, 14) = Br
    MsgBox "读取数据成功"
    Application.StatusBar = False
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub


Private Function Data()
Dim Ar, Dic, I&, J&
    Ar = Sheets("取数规则").Range("a1").CurrentRegion
    Set Dic = CreateObject("Scripting.Dictionary")
    For I = 2 To UBound(Ar)
    Set Dic(Ar(I, 1)) = CreateObject("Scripting.Dictionary")
        For J = 2 To UBound(Ar, 2)
            If Ar(I, J) <> "" Then
                Dic(Ar(I, 1))(Ar(I, J)) = True
            End If
        Next J
    Next
    Set Data = Dic
End Function