VBA：将多个 Word 文件合并为一个后，Microsoft Word 进程不退出

Question

我正在尝试将多个 Word 文件合并为一个。我在 MS Excel 的 VBA 例程中执行此操作。 Word 文件都在一个名为“files”的文件夹中，我想在上一层的文件夹中创建一个新文件“combinedfile.docx”。我面临的问题是关于合并文件后 Word 进程的行为方式（在执行 VBA 函数后是否退出）。在某些机器上，此过程工作正常（除了它的第 2 页和最后一页为空白），而在其他一些机器上，合并的文档包含一个空白页，并且进程管理器显示由 VBA 函数启动的 Word 进程仍然正在运行。

1. 我不习惯 VBA 编程，正如您在下面的代码中看到的那样，我不知道关闭打开的文档和退出打开的 Word 进程的正确方法。如果有人可以看看我所做的并提出解决此问题的方法，那将非常有帮助。

2. 我也很想知道这是否是合并多个 Word 文件的正确方法。如果有更好的方法，请告诉我。

    'the flow:
    '  start a word process to create a blank file "combinedfile.docx"
    '  loop over all documents in "files" folder and do the following:
    '    open the file, insert it at the end of combinedfile.docx, then insert pagebreak
    '  close the file and exit the word process

    filesdir = ActiveWorkbook.Path + "\" + "files\"
    thisdir = ActiveWorkbook.Path + "\"
    singlefile = thisdir + "combinedfile.docx"

    'if it already exists, delete
    If FileExists(singlefile) Then
      SetAttr singlefile, vbNormal
      Kill singlefile
    End If

    Dim wordapp As Word.Application
    Dim singledoc As Word.Document
    Set wordapp = New Word.Application
    Set singledoc = wordapp.Documents.Add
    wordapp.Visible = True
    singledoc.SaveAs Filename:=singlefile
    singledoc.Close    'i do both this and the line below (is it necessary?)
    Set singledoc = Nothing
    wordapp.Quit
    Set wordapp = Nothing

    JoinFiles filesdir + "*.docx", singlefile

    Sub JoinFiles(alldocs As String, singledoc As String)
      Dim wordapp As Word.Application
      Dim doc As Word.Document
      Set wordapp = New Word.Application
      Set doc = wordapp.Documents.Open(Filename:=singledoc)
      Dim filesdir As String
      filesdir = ActiveWorkbook.Path + "\" + "files\"

      docpath = Dir(alldocs, vbNormal)

      While docpath  ""
        doc.Bookmarks("\EndOfDoc").Range.InsertFile (filesdir + docpath)
        doc.Bookmarks("\EndOfDoc").Range.InsertBreak Type:=wdPageBreak
        docpath = Dir
      Wend
      doc.Save
      doc.Close
      Set doc = Nothing
      wordapp.Quit
      Set wordapp = Nothing  
    End Sub

Answer 1

我建议通过以下方式优化您的代码：

• 只打开一次 WordApp 并将文件移动到其中而不关闭/重新打开
• 无需预先杀掉combineddoc，它只会被新文件覆盖
• 不需要 Word.Document 对象，一切都可以在 Word.Application 对象中完成

所以代码变得简单多了：

Sub Merge()
Dim WordApp As Word.Application
Dim FilesDir As String, ThisDir As String, SingleFile As String, DocPath As String
Dim FNArray() As String, Idx As Long, Jdx As Long ' NEW 11-Apr-2013

    FilesDir = ActiveWorkbook.Path + "\" + "files\"
    ThisDir = ActiveWorkbook.Path + "\"
    SingleFile = ThisDir + "combinedfile.docx"
    Set WordApp = New Word.Application

' NEW 11-Apr-2013 START
    ' read in into array
    Idx = 0
    ReDim FNArray(Idx)
    FNArray(Idx) = Dir(FilesDir & "*.docx")
    Do While FNArray(Idx) <> ""
        Idx = Idx + 1
        ReDim Preserve FNArray(Idx)
        FNArray(Idx) = Dir()
    Loop
    ReDim Preserve FNArray(Idx - 1) ' to get rid of last blank element
    BubbleSort FNArray
' NEW 11-Apr-2013 END

    With WordApp
        .Documents.Add
        .Visible = True

' REMOVED 11-Apr-2013 DocPath = Dir(FilesDir & "*.docx")
' REMOVED 11-Apr-2013 Do While DocPath <> ""
' REMOVED 11-Apr-2013     .Selection.InsertFile FilesDir & DocPath
' REMOVED 11-Apr-2013     .Selection.TypeBackspace
' REMOVED 11-Apr-2013     .Selection.InsertBreak wdPageBreak
' REMOVED 11-Apr-2013     DocPath = Dir
' REMOVED 11-Apr-2013 Loop

' NEW 11-Apr-2013 START
        For Jdx = 0 To Idx - 1
            .Selection.InsertFile FilesDir & FNArray(Jdx)
            .Selection.TypeBackspace
            .Selection.InsertBreak wdPageBreak
        Next Jdx
' NEW 11-Apr-2013 END

        .Selection.TypeBackspace
        .Selection.TypeBackspace
        .Selection.Document.SaveAs SingleFile
        .Quit
    End With
    Set WordApp = Nothing
End Sub

' NEW 11-Apr-2013 START
Sub BubbleSort(Arr)
Dim strTemp As String
Dim Idx As Long, Jdx As Long
Dim VMin As Long, VMax As Long

    VMin = LBound(Arr)
    VMax = UBound(Arr)

    For Idx = VMin To VMax - 1
        For Jdx = Idx + 1 To VMax
            If Arr(Idx) > Arr(Jdx) Then
                strTemp = Arr(Idx)
                Arr(Idx) = Arr(Jdx)
                Arr(Jdx) = strTemp
            End If
        Next Jdx
    Next Idx
End Sub
' NEW 11-Apr-2013 END

2013 年 4 月 11 日编辑 删除了代码中的原始 cmets 添加数组和冒泡排序逻辑以保证文件按字母顺序检索