word变量中没有documents对象_ExcelVBA_033 Excel从Word表格提取数据

一、需求说明

    有时我们需要从Word文档的表格里提取数据，比如word文档中的简历信息，需要将姓名、性别、籍贯等信息提取到Excel工作表中，每个文档仅有一个人的简历。

1.word文档截图

2.excel工作表截图

二、实现思路

        使用一张工作表保存Excel工作表中信息的字段列名和word文档表格的行列号之间的对应关系，获取word文档路径之后，逐个打开，按照映射关系提取对应数据。word文档表格内容之后会有一个尾随的空白，提取时需要剔除。

配置关系表：

三、实现代码

Public Sub Basic_CodeFrame()    '作者  DG-NextSeven    'QQ   84857038    '日期  2019年3月23日    '说明                                                      '声明 过程中需要使用到的变量    Dim Wb As Workbook    Dim data_Sht As Worksheet    Dim ini_Sht As Worksheet    Dim row, col, i, dic As Object    Dim filepath, folderpath, filefilter    Dim wdApp, wdDoc                                                        '连接当前工作簿    Set Wb = Application.ThisWorkbook        '当前工作簿所在文件夹路径    folderpath = Wb.Path & "\"        'word文档文件格式过滤    filefilter = "*.doc*"    '查找word文档,保存到数组中    filepaths = GetFiles(folderpath, filefilter)         '能查找到word文档才继续    If Not IsEmpty(filepaths) Then                                                                     '1读取用户配置        Set dic = CreateObject("Scripting.Dictionary") '创建字典保存配置关系        Set ini_Sht = Wb.Worksheets("配置")        With ini_Sht            i = 2            Do While .Cells(i, 1) <> ""                Key = .Cells(i, 1).Value '以列名为关键字                row = .Cells(i, 2).Value                col = .Cells(i, 3).Value                dic(Key) = Array(row, col)                i = i + 1            Loop        End With                                                                    '2获取数据        Set data_Sht = Wb.Worksheets("数据")        '仅保留表头，清除其他数据        data_Sht.UsedRange.Offset(1).Clear        '创建一个word应用程序对象        Set wdApp = CreateObject("Word.Application")        '循环所有文档        i = 1        For Each filepath In filepaths            '打开指定路径的word文档            Set wdDoc = wdApp.documents.Open(filepath)            i = i + 1            '循环所有信息点            For Each j In dic.keys                row = dic(j)(0)                col = dic(j)(1)                '根据行列号提取内容                Text = wdDoc.Tables(1).cell(row, col).Range.Text                '替换掉word表格内容尾随的空白                data_Sht.Cells(i, j).Value = Replace(Text, Chr(7), "")            Next j                                                '关闭word文档，不保存更改            wdDoc.Close False        Next filepath '下一个word文档                                                                   '退出word应用程序        wdApp.Quit                                                                   End If            '释放对象    Set wdApp = Nothing    Set wdDoc = Nothing    Set Wb = Nothing    Set data_Sht = Nothing    Set int_sht = Nothing    Set dic = NothingEnd Sub'根据指定的文件夹路径和过滤字符，获得文件路径数组Function GetFiles(ByVal folderpath As String, ByVal filefiter As String) As String()    Dim filename As String, filepaths() As String    Dim n As Integer    ReDim filepaths(1 To 1)    filename = Dir(folderpath & filefiter)    Do While filename <> ""        n = n + 1        ReDim Preserve filepaths(1 To n)        filepaths(n) = folderpath & filename        filename = Dir    Loop    GetFiles = filepathsEnd Function

四、案例下载链接

链接：https://pan.baidu.com/s/1LJgm83nn92DtEx_sImfm4g

提取码：cj4u