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( To ,  To )
     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 +
         With Table
         '读取子table
          Set eTable = Table.cell(, ).Tables()
          Br(K, ) = Replace(eTable.cell(, ).Range.Text, "", "")
          Br(K, ) = Replace(eTable.cell(, ).Range.Text, "", "")
          Br(K, ) = Replace(eTable.cell(, ).Range.Text, "", "")
          Br(K, ) = Replace(eTable.cell(, ).Range.Text, "", "")
         KK =
         '读取Table
             For Each RKey In Dic.keys
                 For Each Ckey In Dic(RKey).keys
                 KK = KK +
                     Br(K, KK) = Replace(.cell(RKey, Ckey).Range.Text, "", "")
                     If KK =  Then KK = KK +
                 Next
             Next
         End With
     Next
     Doc.Close
     WordApp.Visible = True
     WordApp.Quit
     Set WordApp = Nothing
     Range("a2").Resize(K, ) = 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 =  To UBound(Ar)
     Set Dic(Ar(I, )) = CreateObject("Scripting.Dictionary")
         For J =  To UBound(Ar, )
             If Ar(I, J) <> "" Then
                 Dic(Ar(I, ))(Ar(I, J)) = True
             End If
         Next J
     Next
     Set Data = Dic
 End Function