Summary:

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.

Thoughts…

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:

Download: Create Individual or Mass Letters.xlsm
Download: Sample Letter.docx

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:

Have fun, this solution will work for you, now you will have more time. Spend it wisely… 🙂