别再傻傻复制粘贴啦！这串代码让你一键合并所有Word文档，准时下班！

之前同大家分享过在Word里面一键合并文档的VBA代码，好多朋友都说好用。不过有读者留言问：能不能在Excel里面直接合并Word文档啊？当然可以啦！今天就来给大家安排一个Excel运行、一键合并文件夹里所有Word文档的神操作，保证你用过之后直呼“真香”！

这段代码能干啥？

你只要选一个文件夹，代码就会自动把里面所有的Word文件（.doc、.docx通通搞定）按顺序拼成一个大文档，每个文件从新的一页开始，最后保存成“合并后的文档.docx”。再也不用挨个打开、复制、粘贴，手指头都省下来啦！

操作超简单

1. 1. 打开Excel，按Alt+F11进入VBA编辑器。
2. 2. 插入模块（菜单：插入 → 模块）。
3. 3. 把下面的代码直接粘贴进去。
4. 4. 按F5运行，选文件夹，然后……喝杯茶，等它自己搞掂！

Sub MergeWordDocsInFolder()    Dim fd As FileDialog    Dim strFolderPath As String    Dim strFileName As String    Dim wdApp As Object          ' Word.Application    Dim destDoc As Object         ' 合并后的目标文档    Dim destRange As Object       ' 目标文档中的范围    Dim i As Integer    Dim bCreatedNewApp As Boolean ' 是否新建了 Word 实例    Const wdPageBreak As Long = 7                 ' 分页符常量    Const wdFormatDocumentDefault As Long = 16    ' 默认 Word 文档格式    ' 选择文件夹    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    If fd.Show = -1 Then        strFolderPath = fd.SelectedItems(1)    Else        MsgBox "没有选择目录。", vbExclamation        Exit Sub    End If    If Right(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"    ' 连接 Word    On Error Resume Next    Set wdApp = GetObject(, "Word.Application")    If Err.Number <> 0 Then        Set wdApp = CreateObject("Word.Application")        bCreatedNewApp = True    End If    On Error GoTo 0    If wdApp Is Nothing Then        MsgBox "无法启动 Microsoft Word，请检查安装。", vbCritical        Exit Sub    End If    wdApp.Visible = False   ' 后台运行，不弹窗    Set destDoc = wdApp.Documents.Add(Visible:=False)    Set destRange = destDoc.Range(0, 0)    strFileName = Dir(strFolderPath & "*.doc*")    i = 0    Do While strFileName <> ""        If Left(strFileName, 2) <> "~$" Then            destRange.InsertFile FileName:=strFolderPath & strFileName, _                                 Range:="", _                                 ConfirmConversions:=False            Set destRange = destDoc.Range(destDoc.Range.End - 1, destDoc.Range.End - 1)            destRange.InsertBreak Type:=wdPageBreak            Set destRange = destDoc.Range(destDoc.Range.End - 1, destDoc.Range.End - 1)            i = i + 1        End If        strFileName = Dir    Loop    If i > 0 Then        destDoc.SaveAs2 FileName:=strFolderPath & "合并后的文档.docx", _                        FileFormat:=wdFormatDocumentDefault        destDoc.Close SaveChanges:=False        MsgBox "已合并 " & i & " 个文档，保存到：" & vbCrLf & strFolderPath & "合并后的文档.docx", vbInformation    Else        destDoc.Close SaveChanges:=False        MsgBox "文件夹中没有找到 Word 文档。", vbExclamation    End If    If bCreatedNewApp Then wdApp.Quit    Set wdApp = Nothing    Set destDoc = Nothing    Set destRange = NothingEnd Sub

#VBA #办公自动化 #Excel技巧 #告别加班