VBA Automated Mailmerge using 2 templates based on cell value

Question

Scenario: I have a spreadsheet used for generating letters via an automated mail merge macro. The spread typically contains about 2000 rows

Problem: I need to have the ability to create letters using 2 different letter templates based on cell values in a column. In the example below, the value on column C should dictate which letter template will be used for each row.

Example

      Col A        Col B            Col C
      John         Smith           YES           Letter Template 1 to be used
      Joe            Henricks      No            Letter Template 2  to be used
       Mark        Jones            YES          Letter Template 1  to be used

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Here is some VBA I was playing with but can't quite get it working for the 2 different letters.

I've also tried using IF, THEN, ELSE statements but still can't get it working

   Sub CommandButton2_Click()

   Selection.AutoFilter   '''''''''' This should filter all rows based on the YES value 
    ActiveSheet.Range("D1:AH1").AutoFilter Field:=31, Criteria1:= _
    "YES"

     '''''''''''''''''''''''''''''''''''''''''

   Dim WordApp As Object
   Dim rng As Range
   Range("A1:H1").Select

    Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("D1:AH1"))
    rng.SpecialCells(xlCellTypeVisible).Select


   On Error Resume Next
   Set WordApp = GetObject(, "Word.Application")
   On Error GoTo 0

   If WordApp Is Nothing Then
   Set WordApp = CreateObject("Word.Application")
   End If
    ''' This should run the macro using the YESletter Template
           WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\YESletter.docm""
   WordApp.Run "Module1.SaveIndividualWordFiles"


   '''''''''''''''''''''''''''''''''''''''''

   Selection.AutoFilter   '''''''''' This should filter all rows        based        on        the NO value 
ActiveSheet.Range("D1:AH1").AutoFilter Field:=31, Criteria1:= _
    "Post"

   '''''''''''''''''''''''''''''''''''''''''

   On Error Resume Next
   Set WordApp = GetObject(, "Word.Application")
   On Error GoTo 0

   If WordApp Is Nothing Then
   Set WordApp = CreateObject("Word.Application")
   End If

    ''' This should run the macro using the NOletter Template
           WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\NOletter.docm"
   WordApp.Run "Module1.SaveIndividualWordFiles"

   End

Here's the IF, THEN, ELSE statement method

   If ThisWorkbook.Sheets("LetterData").Range("AH").Value = "YES" Then

       WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\YESletter.docm"
   WordApp.Run "Module1.SaveIndividualWordFiles"

   ELSE

       WordApp.Visible = False
   WordApp.Documents.Open "\\....\docs\lg\Letterbuilder\NOletter.docm"
   WordApp.Run "Module1.SaveIndividualWordFiles"

   End

Answer 1

there are some major flaws in your code:

• to open a Word document with a given template you must use Documents object Add() method, instead of Open() one

• Word templates documents have ".dot" or ".dotx" extension, instead of ".docm" I see in your code

• set only one Word application and use it throughout your macro

  and eventually "dispose" it with

• finally, never use End statement

  just use End Sub

so here follows a possible code:

Option Explicit

Sub CommandButton2_Click()
    Dim wordApp As Object

    Set wordApp = GetWordObject '<--| get a Word object
    If wordApp Is Nothing Then Exit Sub '<--| if no Word Object has been gotten then exit sub

    With ThisWorkbook.Sheets("LetterData") '<--| reference your letter worksheet
        With Application.Intersect(.UsedRange, Range("D1:AH1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
            CreateWordDocuments .Cells, "YES", wordApp, "\\....\docs\lg\Letterbuilder\YESletter.dotx" '<--| process "YES" documents
            CreateWordDocuments .Cells, "NO", wordApp, "\\....\docs\lg\Letterbuilder\NOletter.dotx" '<--| process "NO" documents
        End With
        .AutoFilterMode = False '<--| show all rows back and remove autofilter
    End With

    '"dispose" Word
    wordApp.Quit True '<--| quit Word and save changes to open documents
    Set wordApp = Nothing
End Sub

Sub CreateWordDocuments(dataRng As Range, criteria As String, wordApp As Object, templateDocPath As String)
    Dim cell As Range
    With dataRng '<--| reference data range
        .AutoFilter Field:=31, criteria1:=criteria '<--| filter it on its column 31 with given criteria
        If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell has been filtered
            For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells
                wordApp.Documents.Add templateDocPath '<-- open the passed Word template
                wordApp.Run "Module1.SaveIndividualWordFiles" '<--| run your macro
            Next cell
        End If
    End With
End Sub

Function GetWordObject() As Object
    Dim wordApp As Object

    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application") '<--| try getting a running Word application
    On Error GoTo 0
    If wordApp Is Nothing Then Set wordApp = CreateObject("Word.Application") '<--| if no running instance of Word has been found then open a new one

    Set GetWordObject = wordApp '<--| return the set Word application
    wordApp.Visible = False
End Function

BTW:

• your data example mentions Col A, Col B and Col C, but your code uses a range form column "D" to "AH"

  I assumed this latter

• your code has a statement with Criteria1:="Post"

  I assumed "YES" and "NO" as the only criteria

but all these aspects are easily settable in the proposed code