批量提取多个word目录中的内容汇总到一个excel中

45681235

我有很多相同格式的目录，现在要把相关内容汇总到一个excel中，求教各位大神怎么弄才好？

z9bhd

要汇总哪些内容？只有你自己才知道哪些是相关内容

45681235

z9bhd 发表于 2021-4-2 11:28
要汇总哪些内容？只有你自己才知道哪些是相关内容

我附件里面excel表格中的内容

z9bhd

45681235 发表于 2021-4-2 11:55
我附件里面excel表格中的内容

文件名“99-2･1･4･23-0383_卷内目录.doc”中的“･”无法处理，改为““99-2.1.4.23-0383_卷内目录.doc”后测试通过
Sub lx()
    Dim wdapp As Object, wd As Object, i%, w$
        Sheet1.Range("a2:c3").ClearContents
        w = Dir(ThisWorkbook.Path & "\*.doc")
        s = Replace(w, ".doc", "")
        Set wdapp = CreateObject("word.application")
        wdapp.Visible = True
        Do
            m = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
            Set wd = wdapp.documents.Open(ThisWorkbook.Path & "\" & w)
            a = wd.tables.Count
            With wd.tables(a)
                b = .Range.Cells.Count
                For i = b To 1 Step -1
                    If InStr(.Range.Cells(i).Range.Text, "-") > 0 Then
                        Sheet1.Cells(m, 1).Value = s
                        Sheet1.Cells(m, 2).Value = Left(.Range.Cells(i - 3).Range.Text, Len(.Range.Cells(i - 3).Range.Text) - 2)
                        Sheet1.Cells(m, 3).Value = Left(.Range.Cells(i).Range.Text, Len(.Range.Cells(i).Range.Text) - 2)
                        Exit For
                    End If
                Next i
            End With
            wd.Close 0
            w = Dir
        Loop Until w = ""
End Sub

z9bhd

修改文件名后测试通过
工作簿1.zip (13.27 KB, 下载次数: 43)

2021-4-2 17:38 上传

点击文件名下载附件

45681235

z9bhd 发表于 2021-4-2 17:31
文件名“99-2･1･4･23-0383_卷内目录.doc”中的“･”无法处理，改为““99-2 ...

我试了下，第一栏目录名称不是对应的文件名称，而是一样的

z9bhd

45681235 发表于 2021-4-6 09:30
我试了下，第一栏目录名称不是对应的文件名称，而是一样的

你模板设置问题，还以为你知道就没提醒你，你仔细看一下数据表中的“C”是合同号吗？你把模板中的“B列”和“C列"对调一下就可以了

z9bhd

45681235 发表于 2021-4-6 09:30
我试了下，第一栏目录名称不是对应的文件名称，而是一样的

不好意思,发错了

z9bhd

45681235 发表于 2021-4-6 09:30
我试了下，第一栏目录名称不是对应的文件名称，而是一样的

Sub lx()
    Dim wdapp As Object, wd As Object, i%, w$
        Sheet1.Range("a2:c3").ClearContents
        w = Dir(ThisWorkbook.Path & "\*.doc")
        's = Replace(w, ".doc", "")'这一句写错地方了
        Set wdapp = CreateObject("word.application")
        wdapp.Visible = True
        Do
            s = Replace(w, ".doc", "")'移到这里应该就可以了，你再试试
            m = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
            Set wd = wdapp.documents.Open(ThisWorkbook.Path & "\" & w)
            a = wd.tables.Count
            With wd.tables(a)
                b = .Range.Cells.Count
                For i = b To 1 Step -1
                    If InStr(.Range.Cells(i).Range.Text, "-") > 0 Then
                        Sheet1.Cells(m, 1).Value = s
                        Sheet1.Cells(m, 2).Value = Left(.Range.Cells(i - 3).Range.Text, Len(.Range.Cells(i - 3).Range.Text) - 2)
                        Sheet1.Cells(m, 3).Value = Left(.Range.Cells(i).Range.Text, Len(.Range.Cells(i).Range.Text) - 2)
                        Exit For
                    End If
                Next i
            End With
            wd.Close 0
            w = Dir
        Loop Until w = ""
End Sub

45681235

z9bhd 发表于 2021-4-6 10:03
不好意思,发错了

大佬，我这个是那块得问题啊？