点击下载此附件

【代码】
Sub把WORD文档中多个表格数据复制粘贴到当前工作表()
Application.ScreenUpdating = False '关闭屏幕刷新
开始时间 = Timer '秒
ActiveSheet.Cells.ClearContents '清除表中已有的数据内容
wjM = ThisWorkbook.Path & "\WORD表格\111多.doc"
Set wDoc = CreateObject(wjM) '定义Word对象
bgS = wDoc.Tables.Count '文档中的表格个数
For g = 1 To bgS
    Set wTable = wDoc.Tables(g) '定义表格对象
    hs = wTable.Rows.Count '计算表格总行数
    ls = wTable.Columns.Count '计算表格总列数
    If g = 1 Then
       wDoc.Range(wTable.Cell(1, 1).Range.Start, wTable.Cell(hs, ls).Range.End).Select '选中表格
       wDoc.ActiveWindow.Selection.Copy '复制表格
       With ActiveSheet '当前工作表
           .Range("D:E").NumberFormatLocal = "@"'文本格式
           .Cells(1, 1).Select '选中第一个单元格
           .PasteSpecial Format:="Unicode 文本" '选择为文本(或Unicode 文本)方式粘贴
       End With
    ElseIf g > 1 Then
       wDoc.Range(wTable.Cell(2, 1).Range.Start, wTable.Cell(hs, ls).Range.End).Select '选中表格第2行到最后一行
       wDoc.ActiveWindow.Selection.Copy '复制表格
       With ActiveSheet '当前工作表
           xrH = .UsedRange.Rows.Count + 1'写入数据的起始行数
           .Cells(xrH, 1).Select '选中第一个单元格
           .PasteSpecial Format:="Unicode 文本" '选择为文本(或Unicode 文本)方式粘贴
       End With
    End If
Next g
With ActiveSheet '当前工作表
     .Cells.EntireColumn.AutoFit '自动调整列宽
     .Cells(1, 1).Select
End With
wDoc.Close '关闭文档
Set wTable = Nothing '释放表格对象变量存储空间
Set wDoc = Nothing '释放文档对象变量存储空间
MsgBox Chr(10) & "成功复制粘贴文件 " & Dir(wjM) & " 中 " & bgS & " 个表格数据到当前工作表" _
       & Chr(10) & Chr(10) & "复制粘贴数据共用 " & Timer - 开始时间 & " 秒", , "复制粘贴WORD多表格数据"
Application.ScreenUpdating = False '关闭屏幕刷新
End Sub
说明：
格式完全相同的多表格复制粘贴到EXCEL工作表，第一个表格整个复制粘贴。第二个表格开始，复制粘贴第二行到最后一行数据区域即可。
根据实际表格数据情况，诸如0打头的数字及身份证号码列，在EXCEL中应该设置对应列为文本格式，否则会出现数据损失，不能完整显示。
如果被操作的WORD文档中只有一个表格，上面的代码仍然适用！