VBA: Microsoft Word process does not exit after combining many Word files into one - windows

Question

I'm trying to merge many Word files into one. I am doing this inside a VBA routine in MS Excel. The Word files are all in a folder named "files" and I want to create a new file "combinedfile.docx" in a folder one-level above that. The problem I'm facing is regarding how the Word process behaves after merging the files (whether or not it exits after the execution of the VBA function). On some machines, this process works fine (except that it has page 2 and the last page as blank), while on some others, the merged document contains a blank page and the Process Manager shows the Word process started by the VBA function as still running.
I am not used to VBA programming and as you can see in the code below, I don't know the right way to close an open document and exit a open Word process. If anyone could look at what I've done and suggest a way to solve this problem, it would be very helpful.
I am also interested to know if this is the right way to merge several Word files. If there's a better way, please let me know.
'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

I propose to optimize your code in following ways:
open the WordApp only once and move files into it without closing/reopening
no need to kill combineddoc upfront, it will be simply overwritten by the new file
no need for a Word.Document object, all can be done in the Word.Application object
so the code gets a lot simpler:
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
EDIT 11-Apr-2013
removed original comments in code
added array and bubblesort logic to guarantee files are retrieved in alphabetical order