excel的表格怎么导入到word 如何使用VBA代码将Word的表格批量写入Excel？

……虽然表面上我还是完整的我

但是体内有什么东西被刺破了

大家好，我是星光。中午大家都好了……呃……不知道说什么好，言归正传……

对了excel的表格怎么导入到word，最近比较懒。。。不行，最近事情有点多。。。你后台问了很多问题，有一些我们之前分享过，点击菜单【VBA相关】 →【常用小码】，可以查看详情；还有一部分我们还没有分享excel的表格怎么导入到word，以后会分享…

当然，可能是很久以后，也可能是明天……不过话又说回来，谁又能说明天会怎样呢？

excel的表格怎么导入到word_如何将excel表格导入word_word里导入excel表格

有不少朋友问VBA多文件协同应用，比如如何将Excel数据写入PPT文件？如何将数据从Word写入Excel？

…

那么我们今天分享的VBA小代码内容就是：

如何将Word文件的表格数据批量写入Excel？

比如有一个Word文件，里面有十几个表格。现在急需将每个表的数据复制到Excel中，每个表都有自己的Sheet。关键是不幸的是，你们的秘书李小姐请了一个月假回国……

操作动画如下：

word里导入excel表格_如何将excel表格导入word_excel的表格怎么导入到word

代码如下

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