如何使用VBA代码将Word的表格批量写入Excel？

Sub GetWordTable()Dim WdApp As ObjectDim objTable As ObjectDim objDoc As ObjectDim strPath As StringDim shtEach As WorksheetDim shtSelect As WorksheetDim i As LongDim j As LongDim x As LongDim y As LongDim k As LongDim brr As VariantSet WdApp = CreateObject("Word.Application")With Application.FileDialog(msoFileDialogFilePicker).Filters.Add "Word文件", "*.doc*", 1'只显示word文件.AllowMultiSelect = False'禁止多选文件If .Show Then strPath = .SelectedItems(1) Else Exit SubEnd WithApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseSet shtSelect = ActiveSheet'当前表赋值变量shtSelect，方便代码运行完成后叶落归根回到开始的地方For Each shtEach In Worksheets'删除当前工作表以外的所有工作表If shtEach.Name <> shtSelect.Name Then shtEach.DeleteNextshtSelect.Name = "EH看见星光"'这句代码不是无聊，作用在于……你猜……'……其实是避免下面的程序工作表名称重复Set objDoc = WdApp.documents.Open(strPath)'后台打开用户选定的word文档For Each objTable In objDoc.tables'遍历文档中的每个表格k = k + 1Worksheets.Add after:=Worksheets(Worksheets.Count)'新建工作表ActiveSheet.Name = k & "表"x = objTable.Rows.Count'table的行数y = objTable.Columns.Count'table的列数ReDim brr(1 To x, 1 To y)'以下遍历行列，数据写入数组brrFor i = 1 To xFor j = 1 To ybrr(i, j) = "'" & Application.Clean(objTable.cell(i, j).Range.Text)'Clean函数清除制表符等'半角单引号将数据统一转换为文本格式，避免身份证等数值变形NextNextWith [a1].Resize(x, y).Value = brr'数据写入Excel工作表.Borders.LineStyle = 1'添加边框线End WithNextshtSelect.SelectobjDoc.Close: WdApp.QuitApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueSet objDoc = NothingSet WdApp = NothingMsgBox "共获取：" & k & "张表格的数据。"End Sub