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:
Option Explicit Sub CreateLetterForVisibleRows() 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 DoEvents '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") Err.Clear If WdApp Is Nothing Then Set WdApp = CreateObject("Word.Application") Set WdDoc = WdApp.Documents.Open(Fname) Else On Error GoTo DocNotOpen Set WdDoc = WdApp.Documents(Replace(Fname, FilePath, "")) GoTo DocIsOpen DocNotOpen: Set WdDoc = WdApp.Documents.Open(Fname) End If DocIsOpen: Err.Clear 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 End If Next j If Check = 0 Then NotFound = NotFound & vbCrLf & Cell Check = 0 Next Cell 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 End If 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, _ BitmapMissingFonts:=True, UseISO19005_1:=False End If Next TblCell ExitLine: WdDoc.Close False WdApp.Quit Set WdApp = Nothing Set WdDoc = Nothing End Sub 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 Next ValidateName = Result End Function
Another very important thing you should always do: