VBA实现：将Word中的数据批量提取到Excel

VBA实现：将Word中的数据批量提取到Excel

引用

CSDN

1.

https://blog.csdn.net/nianfen/article/details/141275460

提取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  

知识点

• Excel创建Word程序对象
  这里使用后期绑定的方式创建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函数
  关于Split函数，可以看之前的两篇文章，都有详细的讲解。
• Split函数应用|分离商品和数量
• 字符串函数Split的妙用
• GetOpenFilename函数
  想弹出对话框，打开某些特定后缀的文件，就用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