将Word的表格批量写入Excel

……虽然表面上我还是完整那个我

可是身体有个什么已被刺破

早上好啊都……呃……不知道该说什么了，直接说正事吧……
话说我最近比较懒……不是，我最近事情比较多……你们在后台提了很多问题，有一部分是我们之前分享过的，戳菜单【VBA相关】→【常用小代码】，可见详情；还有一部分是我们还没有分享过，以后会分享……
当然啦，以后可能是很久，也可能就在明天……不过话说回来，明天的事谁说的准呢？

有蛮多的朋友询问VBA多文件协同应用的问题，比如如何将Excel的数据写入PPT文件？如何将Word的数据写入Excel？
……
厚颜无耻的说一句，群众的呼声当然就是我们前进的方向……

所以我们今天分享的VBA小代码的内容是：
如何将Word文件的表格数据批量写入Excel？
比如说，有一个Word文件，里面有十几张表格，现在急需将每个表格的数据复制到Excel，每个表格自成一份Sheet，关键是很不巧，你的秘书MISS李请假一个月回老家了……
操作动画如下：

代码如下
Sub GetWordTable()
Dim WdApp As Object
Dim objTable As Object
Dim objDoc As Object
Dim strPath As String
Dim shtEach As Worksheet
Dim shtSelect As Worksheet
Dim i As Long
Dim j As Long
Dim x As Long
Dim y As Long
Dim k As Long
Dim brr As Variant
Set WdApp = CreateObject("Word.Application")
With Application.FileDialog(msoFileDialogFilePicker)
      .Filters.Add "Word文件", "*.doc*", 1
      '只显示word文件
      .AllowMultiSelect = False
      '禁止多选文件
      If .Show Then strPath = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set shtSelect = ActiveSheet
'当前表赋值变量shtSelect，方便代码运行完成后叶落归根回到开始的地方
For Each shtEach In Worksheets
'删除当前工作表以外的所有工作表
      If shtEach.Name  shtSelect.Name Then shtEach.Delete
Next
shtSelect.Name = "EH看见星光"
'这句代码不是无聊，作用在于……你猜……
'……其实是避免下面的程序工作表名称重复
Set objDoc = WdApp.documents.Open(strPath)
'后台打开用户选定的word文档
For Each objTable In objDoc.tables
'遍历文档中的每个表格
      k = k + 1
      Worksheets.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)
      '以下遍历行列，数据写入数组brr
      For i = 1 To x
         For j = 1 To y
            brr(i, j) = "'" & Application.Clean(objTable.cell(i, j).Range.Text)
            'Clean函数清除制表符等
            '半角单引号将数据统一转换为文本格式，避免身份证等数值变形
         Next
      Next
      With [a1].Resize(x, y)
         .Value = brr
         '数据写入Excel工作表
         .Borders.LineStyle = 1
         '添加边框线
      End With
Next
shtSelect.Select
objDoc.Close: WdApp.Quit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objDoc = Nothing
Set WdApp = Nothing
MsgBox "共获取：" & k & "张表格的数据。"
End Sub
代码已有注释说明，这里就不再啰嗦了。
就酱~
挥手祝安~
图文作者：看见星光

点击【阅读原文】了解详情。