[Jenn68]

I am having a significant problem with an Excel VBA based application that uses a processed excel database as source for mailmerged reports. Depending on the user's input any number of different reports can be created based on the data in the database.

In Excel, based on the user's selection(s) a temporary list (que) is created of all the different reports requested by the user. Excel VBA will use a loop to call a "merge" routine specific to each specific report. If the que has one requested report, Excel will run code to initiate the specific report which includes opening Word, setting the SQL, merging the info to a new document, and saving it. The newly created document remains open. If the user has requested numerous reports be created, this process is repeated for each different report until all reports are created.

Consider an example where the user has requested three reports be processed: HPE-DT, RPE_FR, and WPE-FR

Excel will loop through the mhe merge routine 3 three times.

Here is my issue ... I believe it has something to do with either the .close false statement (not closing the newly created document), or the With .ActiveDocument line (not identifying the correct document as being the active document).

When HPE-DT is created, it is named and saved as HPE-DT.docx. It remains accessible, ie not closed. The next merge routine is called to merge to the document for RPE-FR. The merge is successful and a new document is created. However, it is not saved. The former HPE-DT is resaved with the name RPE-FR.docx. The newly created document sits open named "letters2.docx" and is not saved. When I run the merge routine for the third report, WPE-FR, the RPE-FR.docx is resaved as WPE-FR. The most recently created document sits open named "letters3.docx"

I now have the same document saved under three different names. Only the first one is the proper one. I have two unsaved proper documents. I have to save them as and overwrite the incorrect file.

Here is the VBA code of the merge routine ...

Sub merge2(ByVal i As Long, ByVal ws_vh As Object, ByVal rpt_od As String, objWord As Object)
    'Dim objWord As Object, oDoc As Object
    Dim oDoc As Object
    Dim StrSQL As String, fName As String, StrSrc As String, strFilename As String
    Dim ws_th As Worksheet
    Dim qfile As String, st_srchnfn As String, wb_qfile2 As Workbook
    
    Const wdSendtToNewDocument = 0
    Const wdSendToPrinter = 1
    Const wdFormLetters = 0
    Const wdDirectory = 3
    Const wdMergeSubTypeAccess = 1
    Const wdOpenFormatAuto = 0
    qfile2 = ws_vh.Range("B4")
    
    st_srchfn = "H:\PWS\Parks\Parks Operations\Sports\Sports15\DATA1\" & qfile2
    Set wb_qfile2 = Workbooks(qfile2)
    If wb_qfile2 Is Nothing Then
        MsgBox qfile2 & " is NOT open."
    Else
        'MsgBox qfile2 & " is open"
        wb_qfile2.Close False
    End If
    
    Set ws_th = Workbooks("Sports15b.xlsm").Worksheets("TEMP_HOLD")
    
    itype = Right(ws_th.Range("A" & i), 2)
    isubresp = Left(ws_th.Range("A" & i), 3)
    
    If itype = "DR" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\v1\DR15v1.docx"
    ElseIf itype = "DT" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\v1\DT15v1.docx"
    ElseIf itype = "FR" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\v1\FR15v1.docx"
    ElseIf itype = "FT" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\v1\FT15v1.docx"
    ElseIf itype = "CR" Then
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\v1\CR15v1.docx"
    Else
        fName = "H:\PWS\Parks\Parks Operations\Sports\Sports15\REPORTS\v1\CT15v1.docx"
    End If
    
    StrSrc = "H:\PWS\Parks\Parks Operations\Sports\Sports15\DATA1\" & ws_vh.Range("B4")
 
    StrSQL = "SELECT * FROM [CORE$] WHERE [TYPE]='" & itype & "' AND [SIG_CREW]='" & isubresp & "' " & _
        "ORDER BY [STARTS] ASC, [COMPLEX] ASC, [UNIT] ASC"
 
    'Set objWord = CreateObject("Word.Application")
    With objWord
        .DisplayAlerts = False
        .Visible = True
        Set oDoc = .documents.Open(Filename:=fName, ConfirmConversions:=False, _
            ReadOnly:=True, AddToRecentFiles:=False, Visible:=True)
        With oDoc
            With .MailMerge
                .MainDocumentType = wdFormLetters
                .Destination = wdSendtToNewDocument
                .SuppressBlankLines = True
                .OpenDataSource Name:=StrSrc, AddToRecentFiles:=False, LinkToSource:=False, ConfirmConversions:=False, _
                    ReadOnly:=True, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "User ID=Admin;Data Source=" & StrSrc & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";", _
                    SQLStatement:=StrSQL, SQLStatement1:="", SubType:=wdMergeSubTypeAccess
                .Execute Pause:=False
            End With
            .Close False
        End With
        .DisplayAlerts = True
        
        With .ActiveDocument
            If .Sections.Count  1 Then
                For Each HdFt In .Sections(.Sections.Count).Headers
                    If HdFt.Exists Then
                        HdFt.Range.FormattedText = .Sections(1).Headers(HdFt.Index).Range.FormattedText
                        HdFt.Range.Characters.Last.Delete
                    End If
                Next
                For Each HdFt In .Sections(.Sections.Count).Footers
                    If HdFt.Exists Then
                        HdFt.Range.FormattedText = .Sections(1).Footers(HdFt.Index).Range.FormattedText
                        HdFt.Range.Characters.Last.Delete
                    End If
                Next
            End If
            Do While .Sections.Count  1
                .Sections(1).Range.Characters.Last.Delete
                DoEvents
            Loop
            .Range.Characters.Last.Delete
        End With
    End With

    Set oDoc2 = objWord.ActiveDocument
    With oDoc2
        myPath = "H:\PWS\Parks\Parks Operations\Sports\Sports15\WORKORDERS\" & Format(ws_vh.Range("B2"), "ddd dd-mmm-yy")
        .SaveAs myPath & "\" & rpt_od & ".docx"
    End With
        
    AppActivate "Microsoft Excel"
    Set oDoc = Nothing: Set oDoc2 = Nothing ': Set objWord = Nothing
    'End If
End Sub

This is a critical hurdle in the success of my application. I am not proficient enough on my own with VBA or understanding mailmerges so I hope someone is able to assist in helping me resolve the issue.

Thank you all in advance.

Please note, this same problem has been cross posted here. I am simply targeting a different group of individuals by cros posting this problem.