将word表格中数据提取到excel表格中（超好用）

乐乐2006201505

自己工作中要用到，网上搜索后感觉比较好的两个帖子中代码，特分享给需要的坛友。
Option Explicit
Sub GetDocTablletoSheet()
'请在EXCEL VBE中引用MS WORD   http://xysj1980.blog.163.com/blo ... 398201221843054403/
    Dim wdApp As Word.Application, wdDoc As Word.Document, wdTable As Word.Table
    Dim strArray() As Variant, xlSheet As Worksheet, myDialog As FileDialog, oSel As Variant, otb As Table
    Dim myArray() As String, r As Integer, i As Integer, m As Integer
    On Error Resume Next
    r = ActiveSheet.[a65536].End(xlUp).Row
    '定义一个一维数组，给EXCEL数据表表头赋值
'    strArray = Array("车型代号", "整车编号", "内部尺寸", "发动机型号", "轴距(mm)", "车身", "变速箱(型式/型号)", "型式/型号")
    If r > 2 Then
        Range("a2:b" & r).ClearContents
    End If
    r = ActiveSheet.[a65536].End(xlUp).Row
    Set wdApp = New Word.Application '取得一个New Word对象
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show = -1 Then    '确定
        Application.ScreenUpdating = False
            For Each oSel In .SelectedItems    '在所有选取word文档中循环
'            m = .SelectedItems.Count         '此句代码为多选文件数量
            m = 2                              '此处数字2即提取word表格中几个数据，亦即提取数据后工作表中列数
            ReDim myArray(m - 1)
                Set wdDoc = wdApp.Documents.Open(Filename:=oSel, Visible:=False)
'                For i = 1 To wdDoc.Tables.Count '在一个word文档的所有表格中循环
                    Set wdTable = wdDoc.Tables(1)
                    With wdTable '将word文档中指定的单元格内容赋值给数组
                       myArray(0) = Replace(.Cell(1, 2).Range.Text, Chr(13) & Chr(7), "")
                       myArray(1) = Replace(Replace(.Cell(11, 2).Range.Text, Chr(7), ""), Chr(13), Chr(10))
'                       myArray(2) = Replace(.Cell(13, 4).Range.Text, Chr(13) & Chr(7), "")
'                       myArray(3) = Replace(.Cell(15, 5).Range.Text, Chr(13) & Chr(7), "")
'                       myArray(4) = Replace(.Cell(16, 3).Range.Text, Chr(13) & Chr(7), "")
'                       myArray(5) = Replace(.Cell(22, 3).Range.Text, Chr(13) & Chr(7), "")
'                       myArray(6) = Replace(.Cell(26, 3).Range.Text, Chr(13) & Chr(7), "")
'                       myArray(7) = Replace(.Cell(29, 4).Range.Text, Chr(13) & Chr(7), "")
                    End With
                    r = r + 1 '变换行号
                    Sheets(1).Range(Cells(r, 1), Cells(r, 8)).Value = myArray '为单元格区域赋值
'                Next '完成一个文件的赋值
                wdDoc.Close False
            Next
'            With Sheets(1)
'                .Rows(1).Insert '插入表头行
'                .[A1:H1].Value = strArray
'                .UsedRange.Columns.AutoFit
'            End With
        End If
    End With
    wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub

Sub Macro1byzhaogang1960()    'http://club.excelhome.net/thread-1003675-1-1.html
    Dim p$, f$, rngCopy As Range, rng As Range, a, s$
    Set rngCopy = Sheets("表格模板").Rows("1:6")
    p = ThisWorkbook.Path & "\"
    Application.ScreenUpdating = False
    Cells.Clear
    With CreateObject("WORD.APPLICATION")
        f = Dir(p & "*.doc")
        Do While f <> ""
            rngCopy.Copy
            [a2].Insert Shift:=xlDown
            Set rng = Range("A2:G6")
             .Documents.Open p & f
            With .ActiveDocument.Tables(1)
                rng.Cells(1, 2) = Replace(.Cell(1, 2).Range.Text, Chr(7), "")
                rng.Cells(1, 4) = Replace(.Cell(1, 4).Range.Text, Chr(7), "")
                rng.Cells(1, 6) = Replace(.Cell(3, 2).Range.Text, Chr(7), "")
                rng.Cells(2, 2) = Replace(.Cell(3, 4).Range.Text, Chr(7), "")
                rng.Cells(2, 4) = Replace(.Cell(1, 6).Range.Text, Chr(7), "")
                rng.Cells(2, 6) = Replace(.Cell(4, 4).Range.Text, Chr(7), "")
                s = Replace(.Cell(2, 2).Range.Text, Chr(7), "")
                If InStr(s, "省") Then
                    a = Split(s, "省")
                    rng.Cells(3, 2) = a(0)
                    s = a(1)
                End If
                If InStr(s, "市") Then
                    a = Split(s, "市")
                    rng.Cells(3, 4) = a(0)
                    s = a(1)
                End If
                If InStr(s, "道") Then
                    a = Split(s, "道")
                    rng.Cells(4, 2) = a(0)
                    s = a(1)
                End If
                If InStr(s, "楼") Then
                    a = Split(s, "楼")
                    rng.Cells(4, 4) = a(0)
                End If
                rng.Cells(3, 7) = Replace(.Cell(6, 2).Range.Text, Chr(7), "")
                rng.Cells(4, 7) = Replace(.Cell(6, 4).Range.Text, Chr(7), "")
                rng.Cells(5, 2) = Replace(.Cell(5, 2).Range.Text, Chr(7), "")
                rng.Cells(5, 7) = Replace(.Cell(6, 6).Range.Text, Chr(7), "")
            End With
            .ActiveDocument.Close
            f = Dir
        Loop
        .Quit
    End With
    Application.ScreenUpdating = True
End Sub

182197315

楼主辛苦了，不过你的代码只适用于提取word表格中的内容

乐乐2006201505

182197315 发表于 2017-9-30 21:58
楼主辛苦了，不过你的代码只适用于提取word表格中的内容

你需要什么功能呢？

jjmysjg

能上个附件吗？

乐乐2006201505

我链接帖子中有附件，你自己稍作修改即可。

blackttea1

做个记号。

lzqmsy

做个记号,日后好好学习学习,谢谢楼主!

aman1516

谢谢分享，学习一下。word表格因人而异，横竖格式各有不同，记得有一个可列出一个word文档中有几上表格，每个表格的每个“单元格”位置编号的小工具，这对于每个使用者修改维护代码，如提第几张表格，表内那些内容，那就更清晰明了了

hnnyfcykl

楼主辛苦了，学习中

sunny_8848

谢谢楼主分享