批量提取word中内容及word文件名到excel

幻想中的猪

各位老师，小弟工作中涉及到很多内容格式一致，但文件名有所不同的word文档，想要把特定内容提取到excel中便于管理，无奈纯属vba小白，只好再次向大侠、巨侠、侠圣们求救。

已知条件：1、几十至几百个word文件，绝大部分为docx后缀，少部分为doc后缀；
                 2、word文件名整体结构为 “ 四位数字+单位名称+（备注）” ，部分文件的文件名没有括号及备注的文字，单位名称为2个字或者3个字；
                 3、word文件的内容为一个表格，格式是一致的，但由于内容篇幅的原因，极少部分文件的内容占2页，绝大部分文件内容只占1页。

想实现：1、将文件名中的前四位数字提取到excel表中“编号”一列；
              2、将2个字或者3个字的单位名称提取到excel表中“单位”一列；
              3、如果文件名有括号及备注内容，将备注内容提取到“备注”一列；
              4、将word文件内容表格的“来电时间”、“工单流水号”、“事件主题”、“呼叫电话”、“来电人姓名”、“工单内容”、“到期时间”分别提取到对应列。
              5、不排除极稀有的word文件中表格结构不同（目前处理过超过3700个文件发现1例），只做1-3项对文件名的提取即可。

若全部5项功能难以实现或过于繁琐，恳请能实现“文件名引用+第4项”，到了excel里面对字符串进行一些处理我还是会的。要是word后缀名存在巨大影响，我也可以手动转成docx后缀。小弟使用的2007，系统是win10，先叩谢各位大侠、巨侠、侠圣们！

jiminyanyan

工作量大的估计出手的老师就少了。。。。

幻想中的猪

感谢楼上帮顶了，我也在看以前一些帖子然后试图来改，可惜完全没基础太麻瓜了，只能守株待师了~

qcw911

用正则估计可行

幻想中的猪

至少有4个人给我留言或者其他方式提示我加QQ说有解决方案，在我加了其中一个、查看他的主题也多数为求助、他要求给红包不能试用之后，又看不到这种提示我加QQ的在哪里了，看来对论坛功能都还不熟。这种水友，我觉得不靠谱，对么？

qcw911

幻想中的猪 发表于 2018-6-27 14:31
至少有4个人给我留言或者其他方式提示我加QQ说有解决方案，在我加了其中一个、查看他的主题也多数为求助、 ...

有现成的代码改改就行了

Moneky

如果是以前的话，这个忙我帮定了，现在，人懒了，时间贵了，也就无利不早起了，惭愧啊。

另：如果没有人帮你的话，可以试试我的工具doc2xls，谁说不能完全解决问题，但也能减轻很多工作量了

yylucke

Private Sub CommandButton1_Click()
    Dim WordApp As Object, Doc_Active, fname$, LastRow
   
Application.ScreenUpdating = False
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    WordApp.DisplayAlerts = 0
    On Error Resume Next
   
   
    fname = Dir(ThisWorkbook.Path & "\" & "*.doc*")
    Do Until fname = ""
        If Not IsError(Application.Match(fname, Sheet1.Columns(11), 0)) Then GoTo LineNext
        LastRow = Sheet1.Cells(Sheet1.Cells.Rows.Count, 1).End(xlUp).Row + 1
        Set Doc_Active = WordApp.Documents.Open(ThisWorkbook.Path & "\" & fname, , True)
        With Doc_Active
            Sheet1.Cells(LastRow, 1) = Split(Split(.Range, "工单转办表")(1), Chr(13))(0)
            Sheet1.Cells(LastRow, 2) = Trim(Split(Split(Split(.Range, "事件单位")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 4) = Trim(Split(Split(Split(.Range, "来电时间")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 5) = Trim(Split(Split(Split(.Range, "工单流水号")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 6) = Trim(Split(Split(Split(.Range, "事件主题")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 7) = Trim(Split(Split(Split(.Range, "呼叫电话")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 8) = Trim(Split(Split(Split(.Range, "来电人姓名")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 9) = Trim(Split(Split(Split(.Range, "工单内容")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 10) = Trim(Split(Split(Split(.Range, "到期时间")(1), Chr(13))(1), Chr(7))(1))
            Sheet1.Cells(LastRow, 11) = fname
        End With
        Doc_Active.Close
LineNext:
        fname = Dir
    Loop
    WordApp.Quit
    Set WordApp = Nothing
      
Application.ScreenUpdating = True
End Sub

yylucke

请参见附件

kuangben8

关于遍历文件夹获取数据汇总的求助帖
http://club.excelhome.net/thread-1368474-1-1.html
(出处: ExcelHome技术论坛)
参考看看行不行？