Problem:
I would like to create letters using 2 different letter templates based on a cell value in a column in Excel.
My Question is an extension to the following question:
VBA Automated Mailmerge using 2 templates based on cell value
Example:
In the example below, the value in column C should dictate which letter template will be used for each row. (If cell value is YES use letter template "Yes.docx" otherwise use letter template "No.docx")
Solution proposed by @user3598756 (modified to the above example):
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("Sheet1") '<--| reference your letter worksheet
With Application.Intersect(.UsedRange, Range("A1:C1").EntireColumn) '<--| reference your data range as that in referenced worksheet columns D:H used range
CreateWordDocuments .Cells, "YES", wordApp, "C:\Users\camil\Desktop\YES.docx" '<--| process "YES" documents
CreateWordDocuments .Cells, "NO", wordApp, "C:\Users\camil\Desktop\NO.docx" '<--| 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:=3, Criteria1:=criteria '<--| filter it on its column 3 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
Request:
Unfortunately, the original poster of the question didn't share his "SaveIndividualWordFiles" macro.
I tried to fill in the gap with parts of the VBA I usually use to mailmerge from Word, when I only have one letter template. (Seen below)
However I can't fit the pieces together.
Sub Merge_To_Individual_Files()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & Application.PathSeparator
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Col A")) = "" Then Exit For
StrName = .DataFields("Col A") & " " & .DataFields("Col C")
End With
.Execute Pause:=False
If Err.Number = 5631 Then
Err.Clear
GoTo NextRecord
End If
End With
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
Application.ScreenUpdating = False
End Sub
Any help is appreciated.
