Use Excel to Create Mass Letters
This article describes how to create mass letters from Excel, using a Microsoft Word Document as the letter template and a Map between Excel Defined Names and Word Document Bookmarks.
Starting from the example described in this article, there are numerous things that can be done: if we setup the same bookmarks in Multiple Word Documents, and if we use a multi-select dialog box to open and fill all those selected documents, we can create A SET of different documents for each recipient! Of course, all letters can be attached to an email and sent to that recipient email.
Most of the times,
It should be obvious you first need to create an Excel Table containing the name, physical address, email address, and other pertinent information that is to be inserted into the letter/email of all your intended recipients.
To create a letter for all recipients from your table, a Mail Merge will be all you need. But there are many scenarios where you need flexibility:
- you may want to create a letter for only 1 recipient, without going through all Mail Merge steps;
- or you need to select a range of rows and create letters for all selected rows,
- or, you may want to filter the table for different criteria, and create letters just for visible rows,
- Create Letter for each row in table.
The following will cover all these scenarios, the letters will be saved as PDF files.
The key of this solution is a Map between Excel Defined Names and Word Document Bookmarks.
You can download the sample files from here:
How to Set Up the Map Between Excel Defined Names and Word Bookmarks:
In Map Table, each cell from column B has a defined name, listed in column A. The code will look in the list of defined names from column A, and will try to find a bookmark with the same name in the Word Document you indicated.
Add a bookmark for each duplicate field, but make sure that the bookmark name is present in all duplicates: use duplicate bookmark names like this: RecipientName , RecipientName1, RecipientName2, or even RecipientNamea, RecipientNameb and so on; the code will look for the main part: RecipientName and will send data to any bookmark that has a name starting with this, you can add any suffix you want. Create Duplicate bookmarks for any fields you need.
And the most important thing: make sure that the bookmarks are visible, this way you will be able to see those square brackets that identifies a bookmark, to avoid deleting them when editing the document… From Word Options, Advanced Tab, check the “Show Bookmarks” checkbox, as in image below:
To Insert a Bookmark,
select the bookmark location text, then go to Insert Tab from ribbon, Links Section – Bookmark command; type the names from Excel Map Table – column A names and click Add. You should be able to see the square brackets that defines a bookmark surrounding your selected text. (that text will be replaced with the values sent from Excel defined names).
To see the list of Bookmarks, use the Ctrl+G (Go To) shortcut, and select Bookmarks from list, like in image below:
There are 2 version of the code for creating the letters, one is for the Worksheet_Change Event, that will create letters only for the selected rows, and the code below, which will create letters for all visible rows from table; if there are no filters applied to table columns, a letter for each row will be created.
Here is the code:
Dim Fname As String, BMRange As Object, Cell As Range, DocNotOpen As Label, DocIsOpen As Label, FilePath As String, NewFileName As String
Dim WdApp As Object, WdDoc As Object, Nm As String, ExitLine As Label, DestFolder As String, j As Integer, TblCell As Range
Dim Source As Worksheet, NotFound As String, Check As Integer, ShowOnce As Boolean
Set Source = Worksheets("Create Letters")
DestFolder = "Letters"
ShowOnce = False
If Len(Dir(ThisWorkbook.Path & "\" & DestFolder, vbDirectory)) = 0 Then MkDir ThisWorkbook.Path & "\" & DestFolder
'open dialog window to select word document:
Fname = Application.GetOpenFilename("Word files (*.do*),*.do*", , "Select Letter")
If Fname = "False" Then Exit Sub
FilePath = Left(Fname, InStrRev(Fname, "\"))
Application.DisplayAlerts = False
On Error Resume Next
Set WdApp = GetObject(, "Word.Application")
If WdApp Is Nothing Then
Set WdApp = CreateObject("Word.Application")
Set WdDoc = WdApp.Documents.Open(Fname)
On Error GoTo DocNotOpen
Set WdDoc = WdApp.Documents(Replace(Fname, FilePath, ""))
Set WdDoc = WdApp.Documents.Open(Fname)
On Error GoTo 0
Application.DisplayAlerts = True
'WdApp.Visible = True
'create a letter for each selected rows:
For Each TblCell In Source.ListObjects("MailMergeTable").ListColumns("Recipient Name").DataBodyRange
If Not TblCell.RowHeight = 0 Then
'send data to Map Table:
Range("RecipientName") = Source.Cells(TblCell.Row, Source.Range("MailMergeTable[[#Headers],[Recipient Name]]").Column)
Range("RecipientTitle") = Source.Cells(TblCell.Row, Source.Range("MailMergeTable[[#Headers],[Recipient Title]]").Column)
Range("RecipientCompany") = Source.Cells(TblCell.Row, Source.Range("MailMergeTable[[#Headers],[Recipient Company]]").Column)
Range("RecipientCompanyAddress") = Source.Cells(TblCell.Row, Source.Range("MailMergeTable[[#Headers],[Recipient Company Address]]").Column)
Range("RecipientEmail") = Source.Cells(TblCell.Row, Source.Range("MailMergeTable[[#Headers],[Email]]").Column)
'fill date to table:
Source.Cells(TblCell.Row, Source.Range("MailMergeTable[[#Headers],[Letter Date]]").Column) = Now()
'fill data in bookmarks from Map Table
NotFound = ""
For Each Cell In Range("Map[Field]")
For j = 1 To WdDoc.BookMarks.Count
Nm = WdDoc.BookMarks(j).Name
Set BMRange = WdDoc.BookMarks(j).Range
If InStr(Nm, Cell.Text) > 0 Then
BMRange.Text = Cell.Offset(0, 1).Text
WdDoc.BookMarks.Add Nm, BMRange
Check = 1
If Check = 0 Then NotFound = NotFound & vbCrLf & Cell
Check = 0
If Len(NotFound) > 0 And ShowOnce = False Then
ShowOnce = True
NotFound = Right(NotFound, Len(NotFound) - 1)
MsgBox "There are fields that do not have a correspondent bookmark in " & Replace(Fname, FilePath, "") & vbCrLf & _
"These fields are: " & vbCrLf & NotFound
NewFileName = ThisWorkbook.Path & "\" & DestFolder & "\" & ValidateName(Range("RecipientName") & " " & Range("RecipientTitle")) & " " & Format(Now(), "yyyy-mm-dd-hh-mm") & ".pdf"
WdDoc.ExportAsFixedFormat OutputFileName:=NewFileName, _
ExportFormat:=17, OpenAfterExport:=False, OptimizeFor:=0, Range:=0, _
Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=0, DocStructureTags:=True, _
Set WdApp = Nothing
Set WdDoc = Nothing
Function ValidateName(ByVal txt As String) As String
Dim Char, Result As String, Pos As Integer
Result = ""
Char = ""
Const ValidChars As String = "[A-Z,a-z,0-9, ,_,.,-]"
For Pos = 1 To Len(txt)
Char = Mid(txt, Pos, 1)
If Char Like ValidChars Then Result = Result & Char
ValidateName = Result