搜索
查看: 2084|回复: 0

VBA代码将Word的表格批量写入Excel

[复制链接]

977

主题

1093

帖子

1万

积分

管理员

Rank: 9Rank: 9Rank: 9

积分
15931
发表于 2020-3-25 00:01:39 | 显示全部楼层 |阅读模式

Sub GetWordTable()
    '读取word中的表格数据到excel
    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 k As Long, x As Long, y As Long
    Dim i As Long, j As Long
    Dim brr As Variant
    On Error Resume Next
    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 & "表"
        objTable.Range.Copy
        '整表复制
        ActiveSheet.Paste
        'word表粘贴到excel,保留word表的格式
        '整表复制的方法无法避免身份证之类数据的变形,如果有这样的数据,最好使用如下单元格遍历
        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
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

表格智创网

网站简介:表格智创网,是一家以表格设计和技能分享的专业社区,由会计帮帮网投资建设,尽专业,助提高专业技能。

表格智创网欢迎您!

联系我们

  • 工作时间:早上9:00-16:00
  • 客服电话:18668755857
  • 本站网址:www.excelwps.com
  • 淘宝店址:kjbbw.taobao.com

Powered by Discuz! X3.4 © 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表