多个文件夹中的word如何按子文件名批量合并成一个word

wuqing960412

多个文件夹中的word如何按子文件名批量合并成一个word





假如我有500个文件夹，每一个子文件夹有多个文档，按照子文件合并子文件夹下所有word，并按照子文件名称命名文档名称

wuqing960412

跪求大佬

wuqing960412

大佬，跪求帮忙11111111

z9bhd

wuqing960412 发表于 2021-4-4 10:19
大佬，跪求帮忙11111111

附件？没有附件不好写代码不是

z9bhd

大佬不在岗，菜鸟来帮忙
Sub 合并子文件夹下文档()
    Dim filesys As Object, drv As Object, fd As FileDialog
    Dim wd As Document, wd1 As Document, w$, s$, m$
    Application.ScreenUpdating = False
    Set filesys = CreateObject("scripting.filesystemobject")
    Set fd = Application.FileDialog(4)
    fd.AllowMultiSelect = True
    fd.Show               '请选择子文件夹的上一级文件夹，获得父文件夹路径
    On Error Resume Next
    s = fd.InitialFileName
    For Each drv In filesys.GetFolder(s).SubFolders
        If drv.Size > 0 Then
            m = drv.Name
            Set wd = Documents.Add
        End If
            w = Dir(s & m & "\*.doc?")
        Do
            If InStr(w, ".doc") > 0 Then
               Set wd1 = Documents.Open(s & m & "\" & w)
                    With wd1
                        .Range.Copy
                        .Close 0
                    End With
                    Selection.Paste
            End If
            w = Dir
        Loop Until w = ""
        wd.SaveAs2 (s & m & ".docx")
        wd.Close
     Next drv
     Set fd = Nothing
     Set filesys = Nothing
     Application.ScreenUpdating = True
End Sub

wuqing960412

z9bhd 发表于 2021-4-4 15:43
大佬不在岗，菜鸟来帮忙
Sub 合并子文件夹下文档()
    Dim filesys As Object, drv As Object, fd As Fi ...

大神，你这个是可以的唯一的就是，能不能按照整页的合并，有的会往上面跑，麻烦给给看看https://wwe.lanzous.com/i4r8Lnr4zod

z9bhd

wuqing960412 发表于 2021-4-7 15:27
大神，你这个是可以的唯一的就是，能不能按照整页的合并，有的会往上面跑，麻烦给给看看https://wwe.lanz ...

没有附件乱写一气，你发的这个下载不了

wuqing960412

z9bhd 发表于 2021-4-8 08:23
没有附件乱写一气，你发的这个下载不了

可以呀，兰奏

z9bhd

wuqing960412 发表于 2021-4-7 15:27
大神，你这个是可以的唯一的就是，能不能按照整页的合并，有的会往上面跑，麻烦给给看看https://wwe.lanz ...

估计又发错地方了

z9bhd

wuqing960412 发表于 2021-4-7 15:27
大神，你这个是可以的唯一的就是，能不能按照整页的合并，有的会往上面跑，麻烦给给看看https://wwe.lanz ...

你没有说每个文档要分开，加个分页符就可以了
Sub 合并子文件夹下文档()
    Dim filesys As Object, drv As Object, fd As FileDialog
    Dim wd As Document, wd1 As Document, w$, s$, m$, k%
    Application.ScreenUpdating = False
    Set filesys = CreateObject("scripting.filesystemobject")
    Set fd = Application.FileDialog(4)
    fd.AllowMultiSelect = True
    fd.Show               '请选择子文件夹的上一级文件夹，获得父文件夹路径
    On Error Resume Next
    s = fd.InitialFileName
    For Each drv In filesys.GetFolder(s).SubFolders
        If drv.Size > 0 Then
            m = drv.Name
            n = filesys.GetFolder(s & m & "\").Files.Count
            Set wd = Documents.Add
        End If
            w = Dir(s & m & "\*.doc?")
        k = 0
        Do
            k = k + 1
            If InStr(w, ".doc") > 0 Then
               Set wd1 = Documents.Open(s & m & "\" & w)
                    With wd1
                        .Range.Copy
                        .Close 0
                    End With
                    Selection.Paste
                    If k < n Then Selection.TypeText Chr(12)
                    
            End If
            w = Dir
        Loop Until w = ""
        wd.SaveAs2 (s & m & ".docx")
        wd.Close
     Next drv
     Set fd = Nothing
     Set filesys = Nothing
     Application.ScreenUpdating = True
End Sub