利用VBA从word文档内提取指定内容到excle表格中

52like

作为刚注册论坛不久的小白，最近由于工作关系，每天会收到很多带固定格式内容的WORD文档，为便于统一登记管理，便将这些文档内容统一登记于EXCLE文档中，一项一项登记花费时间比较多，考虑到文档的格式相对统一，因此在参考了网上大神的攻略后，自己动手利用EXCLE自带的VB宏写了一段代码，实现了一键智能导入的目标。自身实力有限，请各位指点，大神勿喷
按照大家要求，先上链接，再做介绍
https://www.aliyundrive.com/s/NK46x7PLaje
提取码: 9o0b

需导入的word文档标题，内容格式如下：  

WORD文档内容

在excle文档中插入窗体按钮，右键指定编写的宏文件后，单击按钮效果如下，文档标题，内容完美显示在excle文档中，而且再次导入文档时，自动识别excle文档最后一行进行填充，不会擦除以前导入的内容。

导入的效果

目前仅能实现单个文件一键导入，整个文件夹的导入还在探索中
具体代码如下：

Sub 提取Word文档内容到Excle()
On Error GoTo Err_cmdimportWord_Click
Dim objwd As Object
Dim objdoc As Object
Dim objTable As Object
Dim strTemplates As String 'word文件路径名
Dim k, n As Integer
Dim mypath As String, myname As String
Dim i As Long

Set objwd = CreateObject("Word.Application")       ' 建立Word会话
objwd.Visible = False                              ' 设定Word应用程序为不可见状态
k = Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row + 1          '查找最后一行行号
n = 0
Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker) '选择单个word文件
         .Filters.Add "word文件", "*.doc*", 1
         .AllowMultiSelect = False
         If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
    End With

    Set objdoc = objwd.Documents.Open(strTemplates, , False)
    Set objTable = objdoc.Tables(1)
    mypath = strTemplates
    myname = Dir(mypath & "*.*")
    Sheet1.Cells(n + k, 2) = myname
    Sheet1.Cells(n + k, 3) = Replace(objTable.Cell(1, 2).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 4) = Replace(objTable.Cell(1, 4).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 5) = Replace(objTable.Cell(1, 6).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 6) = Replace(objTable.Cell(2, 2).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 7) = Replace(objTable.Cell(2, 4).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 8) = Replace(objTable.Cell(2, 6).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 9) = Replace(objTable.Cell(3, 2).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 10) = Replace(objTable.Cell(3, 4).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 11) = Replace(objTable.Cell(4, 2).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 12) = Replace(objTable.Cell(5, 2).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 13) = Replace(objTable.Cell(6, 2).Range.Text, Chr$(13) & Chr$(7), "")
    Sheet1.Cells(n + k, 14) = Replace(objTable.Cell(7, 2).Range.Text, Chr$(13) & Chr$(7), "")

    objdoc.Close   ' 关闭文件

Application.ScreenUpdating = True
Exit_cmdimportWord_Click:
Set objdoc = Nothing
Set objTable = Nothing
Set objwd = Nothing
Exit Sub
Err_cmdimportWord_Click:
MsgBox Err.Description, vbCritical, "出错"
Resume Exit_cmdimportWord_Click
End Sub

fire1119e

感谢楼主，下载试用！

Kls673M

如果反向从表格复制到word文档再按姓名分文档呢！

52like

自己占个沙发

alongzhenggang

suiran 但是  守着吧  万一用找了呢

pdfhvy141

谢楼主分享。成品件发个

ilovei

谢楼主分享

心海伽蓝

Kls673M 发表于 2023-4-28 16:48
如果反向从表格复制到word文档再按姓名分文档呢！

用邮件合并即可

52like

Kls673M 发表于 2023-4-28 16:48
如果反向从表格复制到word文档再按姓名分文档呢！

@心海伽蓝 这位大神说的到位，excle里面自带的邮件合并功能就是实现这个功能得

52like

@pdfhvy141 我导出了一个bas文件，可以直接导入使用的，你试试吧

提取Word文档内容到Excle.rar (987 Bytes, 下载次数: 59)

2023-4-28 17:02 上传

点击文件名下载附件

52like

我看下载附件需要扣除CB，再分享一个BAS的网盘链接，需要的请自取
提取Word文档内容到Excle.bas
https://www.aliyundrive.com/s/NK46x7PLaje
提取码: 9o0b