求助，提取word里面的标题到excel

杭州小菜02

小花鹿 发表于 2019-3-21 11:07
你还没听明白，是如何让程序识别提取的内容

而且看名称就能看出规律：
1、取公司名字，韩国陆军管理有限公司浙江代表处，只要找到 经费收支情况专项审计报告，获取上一行的内容就是公司名称。
2，要去字号，直接获取 中划时代〔2019〕专审字第057号，每份报告这个是唯一值，且在  经费收支情况专项审计报告的下一行就是。
程序应当很清晰的就识别出来了

jiangxiaoyun

中划时代〔2019〕专审字第[0-9]{3}号

查找（使用通配符），然后再读取其段落索引号，减去2，得出标题。

杭州小菜02

jiangxiaoyun 发表于 2019-3-21 11:21
中划时代〔2019〕专审字第[0-9]{3}号

查找（使用通配符），然后再读取其段落索引号，减去2，得出标题。

你好，能发下完整代码吗

mzbao

Sub ReadFromWord()
    Dim oDoc As Object, myPath$, MyName$, txt$
    Dim RegX As Object, objMatchs As Object
    Dim FileName$, FileNo$, i%, k%, fTxt$
   
    myPath = ThisWorkbook.Path & "\"
    MyName = Dir(myPath & "*.doc*")
   
    Set RegX = CreateObject("vbscript.regexp")
    RegX.Global = True

    Do While MyName <> ""
        If InStr(1, MyName, "审计报告") Then
            Set oDoc = GetObject(myPath & MyName)
            txt = oDoc.Range.Text
            oDoc.Close True
            
            txt = Replace(txt, Chr(13), "@")
            RegX.Pattern = "[^@]+@[^@]+@+(中划时代〔\d+〕专审字第\d+号)"
            Set objMatchs = RegX.Execute(txt)
            For i = 0 To objMatchs.Count - 1
                fTxt = objMatchs(i).Value
                FileNo = Mid(fTxt, InStrRev(fTxt, "@") + 1)
                FileName = Replace(Replace(fTxt, FileNo, ""), "@", "")
                k = k + 1
                Cells(1 + k, 1) = k
                Cells(1 + k, 2) = FileName
                Cells(1 + k, 3) = FileNo
            Next
        End If
        MyName = Dir
    Loop

    Set oDoc = Nothing
End Sub

Yalishanda30

附件供参考

杭州小菜02

mzbao 发表于 2019-3-21 12:41
Sub ReadFromWord()
    Dim oDoc As Object, myPath$, MyName$, txt$
    Dim RegX As Object, objMatch ...

大神的代码简洁明了，方便实用，真是厉害，佩服

小花鹿

杭州小菜02 发表于 2019-3-21 11:21
而且看名称就能看出规律：
1、取公司名字，韩国陆军管理有限公司浙江代表处，只要找到 经费收支情况专项 ...

你说得很对，但是需要楼主确认这种规律，但楼主始终没有说出提取内容的规律，如果在楼主现有附件的基础上写了代码，万一再有别的情况，就不适用了，如果楼主自己总结不出规律，也可以提供所有的原始资料，让别人总结规律，这样不至于频繁的修改代码
我也是瞎操心