如何批量按文件夹合并word

wh1813

有205个文件夹，每个文件夹内有2-5个word文档,如何把这205个文件内的word，分别进行合并，形成205个新word，新word名是对应文件夹的名称
cs.rar (69.61 KB, 下载次数: 16)

2021-6-18 14:44 上传

点击文件名下载附件
样例

用了以下代码实现了目标：
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


注意，文档格式必须是docx

daibao88

vba，本论坛往前找，有实例的。

wh1813

daibao88 发表于 2021-6-18 14:44
vba，本论坛往前找，有实例的。

找到了个类似的，但是合并成出来的文档都是空白的

daibao88

那是你没有读懂VBA代码，根据自己的情况适当修改才行。

wh1813

daibao88 发表于 2021-6-18 15:51
那是你没有读懂VBA代码，根据自己的情况适当修改才行。

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
用了这个代码，完美，分享出来！
注意：
文档必须是docx的，如果有会修改的，也可以尝试修改支持doc格式的

xinhairen999

学习了，收藏备用。

wdpfox

学习了，收藏备用！谢谢分享！

We meet by chance like patches of drifting duckweed,  
May everything be fine with you everyday !
  （你我萍水相逢，愿君一切安好！）