Excel Workbook to Create Word Document and Auto-Run Mail Merge from Excel Workbook

Question

I've got a bit of a tricky one here. Attempting to simplify an existing process.

Existing Process:

Word Document ("Plan Doc Template") is entirely composed of INCLUDETEXT fields that pull Bookmarked sections from another Word Document ("Source Plan Doc" we'll call it) that includes merge-fields in its bookmarked sections which are from an Excel Workbook ("Mail Merge Workbook").

The current process involves the user copying a Plan Doc Template and a Mail Merge Workbook and pasting it into any folder they choose. The user then fills out the Mail Merge Workbook, saves and closes, and runs a Mail Merge through the Plan Doc Template Word Doc. This pulls in bookmarked sections from the Source Plan Doc depending on the Mail Merge Workbook fields selected. The user then removes all INCLUDETEXT fields with CTRL + SHIFT + F9 to turn fields of Plan Doc Template into workable text.

(Hopeful) Future Process:

1. The user copies a Mail Merge Workbook and pastes it into their desired folder. Fills out the Mail Merge Workbook. (Manual Step)
2. Runs VBA Code.
3. VBA copies the Plan Doc Template and pastes in the Mail Merge Workbook's folder that just ran the VBA code.
4. VBA renames the Plan Doc Template Word Doc based on fields within the Mail Merge Workbook.
5. VBA runs a Mail Merge within the Plan Doc Template
6. VBA highlights entire document and CTRL + SHIFT + F9 to turn Field Codes into workable text.

Is it possible to do all this from an Excel VBA code or would I need a separate code after the Plan Doc has been created to run the mail merge and do the CTRL + SHIFT + F9 steps?

PS I use Excel Worksheets via DDE Selection to get the correct formatting from Mail Merge Workbook to Document. Hoping that can be included in the VBA code, as well.

Help would be greatly appreciated on this one, thanks,

Rich

Answer 1

It looks like you can have the whole thing run with one macro from Excel, without the user having to run a second one, using a For loop until wdApp.Documents.Count increases by 1. I did test the following, but with only a very small data set, so it ran very quickly.

Since the user might have more than just the main merge document open, it's important the code can identify and work with the resulting document. Usually, it will have become the ActiveDocument but relying on that is never certain. So I built in a couple of loops to 1) hold the currently open documents in an array then 2) compare those to the currently active document. If the currently active document is not in the array, then the fields are unlinked (that's the equivalent of Ctrl+Shift+F9).

Of course, if you really wanted to identify the new document from all the documents you'd need to loop each document and loop the array, making the comparison. But I've given you the starting point...

Sub MergeWithWord()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim nrDocs As Long
    Dim i As Long, d As Long
    Dim aDocs() As Variant

    Set wdApp = GetObject(, "Word.Application")
    nrDocs = wdApp.documents.Count

    'Get all opened documents so can compare whether a new one
    ReDim Preserve aDocs(nrDocs - 1)
    Set wdDoc = wdApp.activedocument
    For i = 0 To nrDocs - 1
        Set aDocs(i) = wdApp.documents(i + 1)
    Next

    If wdDoc.MailMerge.MainDocumentType <> -1 Then
        wdDoc.MailMerge.Destination = 0
        wdDoc.MailMerge.Execute False
        Do Until wdApp.documents.Count > nrDocs Or i > 1000
            i = i + 1
        Loop
        Set wdDoc = wdApp.activedocument
        For d = 0 To UBound(aDocs)
            If wdDoc Is aDocs(d) Then
                Debug.Print "Not a new doc"
            Else
                Debug.Print wdDoc.FullName
                wdDoc.Fields.Unlink
                Exit For
            End If
        Next
    End If

    Debug.Print nrDocs, i
    MsgBox "Done"

End Sub

Answer 2

May not be the most elegant code but here was what I wound up using to solve my question in case it helps anyone else.

Sub ButtonMerge()
Dim str1 As String
Dim PlanDocTemplate As String
Dim EDrive As String
Dim answer1 As Integer
Dim answer2 As Integer

answer1 = MsgBox("Is this IC Plan Workbook saved in the appropriate Client folder?", vbYesNo + vbQuestion)

If answer1 = vbNo Then
    MsgBox ("Please save this IC Plan Workbook in the appropriate Client folder then run again.")
    Exit Sub
Else
    'do nothing
End If

str1 = "Q:\IC\New Structure\IC Toolkit\Templates\01 Plan Doc Template\16 Source\IC Plan Doc Template v1.0.docx"
PlanDocTemplate = Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx"
EDrive = "E:\" & Range("A1").Value & ".docx"

If Len(Dir(Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx")) = 0 Then
    Call FileCopy(str1, PlanDocTemplate)
Else
    MsgBox ("The Plan document already exists, please delete or rename the existing Plan Doc in folder " _
    & Application.ActiveWorkbook.Path & "\ before creating a new one.")
    Exit Sub
End If

strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
Worksheets("Data").Activate

'Opens New Plan Doc Template
Set appWD = CreateObject("Word.Application")
appWD.Visible = True

appWD.Documents.Open Filename:=PlanDocTemplate

ActiveDocument.MailMerge.OpenDataSource Name:=strWorkbookName, _
Format:=wdMergeInfoFromExcelDDE, _
ConfirmConversions:=True, _
ReadOnly:=False, _
LinkToSource:=True, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
Revert:=False, _
Connection:="Entire Spreadsheet", _
SQLStatement:="SELECT * FROM `Data$`", _
SQLStatement1:="", _
SubType:=wdMergeSubTypeOther

appWD.Visible = True

appWD.Selection.WholeStory
appWD.Selection.Fields.Update
appWD.Selection.Fields.Unlink
ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument
appWD.ActiveDocument.Save

Worksheets("Form").Activate
MsgBox "Successfully Created " & Range("A1").Value & " in Location: " & Application.ActiveWorkbook.Path & "\"

answer2 = MsgBox("Do you want to save a draft in the E:\ drive as well?", vbYesNo + vbQuestion, "E: Drive Copy")

If answer2 = vbYes Then
    If Dir("E:\") <> "" Then
        ActiveDocument.SaveAs2 Filename:= _
        "E:\" & Range("A1").Value & ".docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
        MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
        Exit Sub
    Else
        MsgBox ("Please open the E:\ drive and enter your username/password." & _
        vbCrLf & vbCrLf & "Click Ok when E:\ drive is opened.")
        If Len(Dir("E:\")) = 0 Then
            MsgBox ("Error connecting to E:\ drive." & vbCrLf & vbCrLf & "Please ensure you're connected and try again.")
            Exit Sub
        Else
            ActiveDocument.SaveAs2 Filename:= _
            "E:\" & Range("A1").Value & ".docx", _
            FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
            AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
            EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
            :=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
            MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
            Exit Sub
        End If
    End If
Else
    Exit Sub
End If

End Sub