VBA Automated Mailmerge using 2 templates based on cell value - vba

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