一、需求说明
有时我们需要从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