windows - 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 日 删除了代码中的原始注释 添加数组和冒泡排序逻辑以保证文件按字母顺序检索