今天介绍一个插件,适用下面的场景 插件地址:www.
具体需求 提取Word文档中特定信息到Excel,Word文档结构如下(需提取内容已经用黄色标识): 提取思路 一个文档中,有多个这样的缴费清单,我们要提取的是一些固定关键字之后的数据。 所以,我们循环文档的所有段落,如果包含【物业管理清册】关键字,则获取他的下两行数据,并且提取关键字。 具体代码 Sub 循环打开工作簿() On Error GoTo 1 k = 1 Rows("2:65536").Clear '清除上次数据 Application.DisplayAlerts = False Application.ScreenUpdating = False Application.AskToUpdateLinks = False pth = Application.GetOpenFilename("文件(*.doc*),*.doc*", , "请选择文件", , False) '打开doc后缀的文档 If pth = "False" Then Exit Sub '如果用户选择了取消,直接退出 Set doc = CreateObject("word.application") '创建Word对象 doc.Visible = True '显示word主程序 Set wd = doc.Documents.Open(pth) '打开word文档,赋值给对象变量wd For Each tbl In wd.tables '删除文档中所有的表格,因为表格过多,影响循环段落的效率。 tbl.Delete Next For i = 1 To wd.Paragraphs.Count - 2 '循环到倒数第三段 a = wd.Paragraphs(i).Range.Text '获取这几段的内容,分别赋值给a、b、c变量 b = wd.Paragraphs(i + 1).Range.Text c = wd.Paragraphs(i + 2).Range.Text If InStr(a, "物业管理费缴费清册") Then '开始取数据 k = k + 1 Cells(k, 1) = k - 1 '序号 Cells(k, 2) = l(Split(Split(b, ":")(1), "面积")(0)) '楼号楼室 Cells(k, 3) = l(Split(Split(b, "面积")(1), "㎡")(0)) '面积 Cells(k, 4) = l(Split(Split(c, "姓名")(1), "电话")(0)) '姓名 Cells(k, 5) = l(Split(Split(c, "电话")(1), "月缴费")(0)) '电话 Cells(k, 6) = l(Split(Split(c, "月缴费")(1), "元")(0)) '月缴费 Cells(k, 7) = l(Split(Split(c, "年缴费")(1), "元")(0)) '年缴费 End If Next 1: wd.Close False '关闭原始文档,并且不保存 doc.Quit '关闭Word主程序 Application.DisplayAlerts = True Application.ScreenUpdating = True Application.AskToUpdateLinks = True If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "提取出现错误,联系作者解决!" End If MsgBox "提取完成!" End Sub Function l(s) l = Replace(s, ":", "") '去除冒号自定义函数 End Function 知识点
这里使用后期绑定的方式创建Word主程序,并且新建一个word文档。向Word文档中写入内容123,最后另存为本工作簿路径下的一个文档。 '后期绑定 Sub 操作word1() '打开Word写入文字 Set doc = CreateObject("word.application") '创建Word对象 Set wd = doc.Documents.Add doc.Visible = True strr = 123 '需要导入的字符串 .TypeText strr .TypeParagraph wd.SaveAs ThisWorkbook.Path & "\例子.docx" doc.Quit '关闭程序 End Sub
关于Split函数,可以看之前的两篇文章,都有详细的讲解。
想弹出对话框,打开某些特定后缀的文件,就用GetOpenFilename。具体用法可参见之前的文章。获取文件全路径(一)GetOpenFilename 方法 常用的代码是以下的模板: '允许选择多个文件 Sub 循环打开工作簿() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.AskToUpdateLinks = False pth = Application.GetOpenFilename("文件(*.xls*),*.xls*", , "请选择文件", , True) If IsArray(pth) = False Then Exit Sub For i = 1 To UBound(pth) Set wb = Workbooks.Open(pth(i)) '########汇总数据的核心操作########## wb.Close False Next Application.DisplayAlerts = True Application.ScreenUpdating = True Application.AskToUpdateLinks = True End Sub '只允许选择一个文件 Sub 循环打开工作簿() Application.DisplayAlerts = False Application.ScreenUpdating = False Application.AskToUpdateLinks = False pth = Application.GetOpenFilename("文件(*.xls*),*.xls*", , "请选择文件", , False) Set wb = Workbooks.Open(pth) '########汇总数据的核心操作########## wb.Close False Application.DisplayAlerts = True Application.ScreenUpdating = True Application.AskToUpdateLinks = True End Sub
|
|