MS Word Letter with Variable Data Rows in Body Merge: Background

A couple of years ago I needed to mail merge a list of Addressees into a letter and somehow include their account data - which was variable in nature (1 row of data or 10 rows of data per addressee). A standard Mail Merge in Word was used by taking the variable data and putting it into a Single row with the addressee and fields for Data Rows 1 through 10 for each field - very messy and not pretty. Later, I realized that I could use a VBA Data merge with SQL and then code 2 tables: one with a Single column of data and one iteration through a loop for the Address, a second one of variable rows based on the Count of the recordset to create the second, formatted table.

Vendor Purchase Order Excel Data Source

The Excel file used for this Word data source originated from a query from a SQL Server database - AdventureWorks 2014. An ID field was added to each Group \ Vendor in Column A using a Sequential Integer. This way the group could be called in SQL in Word to retrieve 1 ID at a time.

Create the VBA code to Merge the Address and Row data into MS Word

Create a new Sub in Word VBA that takes an Int as a Variable. Declare the variables and ADODB connections and set the Data Source.

Sub sPrintTable(ByVal iRow As Integer)
 Dim labelrows, labelcolumns, i As Integer
 Dim j As Integer, k As Integer, t As Integer
 Dim rsRows As Integer
 Dim rs As ADODB.Recordset, rsCount As ADODB.Recordset
 Dim cn As ADODB.Connection
 Dim sqlGetTbl As String
 Dim sDataSource As String, sDataTable As String<
 Dim sProvider As String

 Set cn = New ADODB.Connection
 Set rs = New ADODB.Recordset
 Set rsCount = New ADODB.Recordset

 sDataSource = "C:\MS Access\AdvWksOrdersMM.xlsx"
 sDataTable = "Sheet1"

 sProvider = "Microsoft.ACE.OLEDB.12.0;"
 sDataSource = "'" & sDataSource & "'"

 sDataSource = sDataSource & ";Extended Properties='Excel 12.0 Xml;HDR=Yes';"
 sDataTable = "[" & sDataTable & "$]"

 cn.Provider = sProvider
 cn.ConnectionString = "Data Source=" & sDataSource
 cn.Open

Set The Recordset SQL string for a Count of Rows in the data set to the variable rsCount. Also set the Recordset to a SQL String to retrieve the Columns in Excel to the variable rs.

'Recordset to retrieve the row count
 sqlGetTbl = "SELECT COUNT(*) FROM " & sDataTable & " WHERE id = " & iRow  rsCount.Open sqlGetTbl, cn, adOpenDynamic, adLockOptimistic

'Recordset to retrieve the data
 sqlGetTbl = "SELECT PurchaseOrderID, OrderDate, SubTotal, TaxAmt, TotalDue, Vendor, " & _
  " AddressLine1 as Addr1, City + ', ' + StateProvinceCode + ' ' + PostalCode as Addr2 FROM " & _
  sDataTable & " WHERE ID = " & iRow

 sDataTable & _rs.Open sqlGetTbl, cn, adOpenDynamic, adLockOptimistic

 sDataTable & _labelrows = rsCount.Fields(0)

 labelcolumns = 5

Set up the top of the Letter with the date then a single column, 6 row Address table in VBA.

If Len(labelcolumns) > 0 And Len(labelrows) > 0 Then
 ActiveDocument.PageSetup.HeaderDistance = InchesToPoints(0.5)
 ActiveDocument.PageSetup.FooterDistance = InchesToPoints(0.5)
 ActiveDocument.PageSetup.LeftMargin = InchesToPoints(0.75)
 ActiveDocument.PageSetup.RightMargin = InchesToPoints(0.75)

 If iRow = 1 Then
  Selection.WholeStory
  Selection.Delete
 End If

 Selection.TypeParagraph
 Selection.Font.Name = "Times New Roman"
 Selection.Font.Size = "9"
 Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
 Selection.Font.Bold = False
 Selection.TypeText Text:="August 8, 2017" & Chr(11)

 t = (iRow * 2) - 1

 If Not rs.EOF Then
 'table 1 with addr
  ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=6, NumColumns:=1, _
  DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
  wdAutoFitFixed
 ActiveDocument.Tables(t).Columns.PreferredWidth = InchesToPoints(8)
  ActiveDocument.Tables(t).Rows.Height = InchesToPoints(0.2)
  ActiveDocument.Tables(t).Borders(wdBorderLeft).Visible = False
  ActiveDocument.Tables(t).Borders(wdBorderRight).Visible = False
  ActiveDocument.Tables(t).Borders(wdBorderTop).Visible = False
  ActiveDocument.Tables(t).Borders(wdBorderBottom).Visible = False
  ActiveDocument.Tables(t).Borders(wdBorderHorizontal).Visible = False
  ActiveDocument.Tables(t).Borders(wdBorderVertical).Visible = False
 End If

Write a For loop to iterate through table rows 1 thru 3 (fields 5 thru 7) to populate the address. Recordset fields start at column number 6 - 1 (the array begins with 0), so the code needs to subtract 4 from the Field Count of 5 through 7 to populate table rows 1 through 3.

If Not rs.EOF Then
 For k = 5 To 7
  If Len(rs.Fields(k)) > 0 Then
   ActiveDocument.Tables(t).Cell(k - 4, 1).Range.InsertBefore rs.Fields(k)
  End If
 Next k
End If

Here the page has a salutation with 2 line breaks and have 2 blocks of text added for the letter body. Some standard Lorem Ipsum text filler is used for the text blocks in this example.

 Selection.MoveDown Unit:=wdLine, Count:=10
 Selection.TypeParagraph
 Selection.TypeText Text:="Dear Vendor: " & Chr(11) & Chr(11)

 Selection.TypeText Text:="Lorem ipsum dolor sit amet, consectetur adipiscing elit. Suspendisse auctor dapibus augue, nec viverra risus pretium nec. Nullam ac porta lorem, ut fermentum elit. Nullam sagittis eros ac risus lacinia scelerisque sed sed nulla. Ut sed nisl in ex volutpat lobortis. Pellentesque et turpis sit amet mauris aliquam rhoncus. In et commodo dui, eget pulvinar nibh. Donec iaculis ipsum lorem, a ullamcorper augue condimentum sit amet. Duis varius tellus id lorem convallis scelerisque." & Chr(11) & Chr(11)

 Selection.TypeText Text:="Praesent ac diam sit amet ex fermentum aliquet. Praesent ut lectus feugiat, placerat ipsum sollicitudin, mattis enim. Phasellus scelerisque tortor risus, nec scelerisque lacus faucibus vel. Nam eu auctor magna, eget mattis purus. Nulla suscipit urna nec purus pellentesque maximus. Nam mauris eros, dignissim at maximus eget, ornare ut enim. Curabitur magna orci, varius in urna ac, tempor mattis ipsum. Nulla eget accumsan lectus. Lorem ipsum dolor sit amet, consectetur adipiscing elit. Mauris iaculis varius aliquet. Quisque at nulla viverra, gravida nisl eget, elementum ligula. Fusce nibh enim, venenatis nec interdum eget, gravida in libero. Duis sollicitudin lectus eu feugiat tincidunt. Donec sed sapien a ante tempus lobortis. Vestibulum eleifend ante neque, non consectetur leo dictum ut." & Chr(11)

Code the next For loop to get Rows of Purchase Order data and populate it into a table for each count of labelrows. Add the header fields to the first row and some formatting to the currency fields and some column positioning for the cells in the table.

 t = t + 1 '2nd table
  ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=labelrows + 1, NumColumns:= _
   labelcolumns, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
   wdAutoFitFixed
  ActiveDocument.Tables(t).Columns.PreferredWidth = InchesToPoints(8)
  ActiveDocument.Tables(t).Rows.Height = InchesToPoints(0.3)
  ActiveDocument.Tables(t).Borders(wdBorderLeft).Visible = True
  ActiveDocument.Tables(t).Borders(wdBorderRight).Visible = True
  ActiveDocument.Tables(t).Borders(wdBorderTop).Visible = True
  ActiveDocument.Tables(t).Borders(wdBorderBottom).Visible = True
  ActiveDocument.Tables(t).Borders(wdBorderHorizontal).Visible = True
  ActiveDocument.Tables(t).Borders(wdBorderVertical).Visible = True

 i = 1
 j = 1
 rs.MoveFirst

If Not rs.EOF Then
 For j = 1 To labelrows
  For k = 1 To labelcolumns

If j = 1 Then
 ActiveDocument.Tables(t).Cell(j, k).Range.InsertBefore rs.Fields(k - 1).Name
 ActiveDocument.Tables(t).Cell(j, k).Range.Shading.BackgroundPatternColor = wdColorGray15
 ActiveDocument.Tables(t).Cell(j, k).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter

 If Len(rs.Fields(k - 1)) > 0 Then
  If k = 3 Or k = 4 Or k = 5 Then
   ActiveDocument.Tables(t).Cell(j + 1, k).Range.InsertBefore Format(rs.Fields(k - 1), "$###,#00.00")
  Else
   ActiveDocument.Tables(t).Cell(j + 1, k).Range.InsertBefore rs.Fields(k - 1)
  End If
 End If

 Selection.EndOf Unit:=wdParagraph, Extend:=wdExtend
 Selection.Range.Font.Bold = True
 Selection.Range.Font.Underline = wdUnderlineSingle

Else
 If Len(Trim(rs.Fields(k - 1))) > 0 Then
  If k = 3 Or k = 4 Or k = 5 Then
   ActiveDocument.Tables(t).Cell(j + 1, k).Range.InsertBefore Format(rs.Fields(k - 1), "$###,#00.00")
  Else
   ActiveDocument.Tables(t).Cell(j + 1, k).Range.InsertBefore rs.Fields(k - 1)
  End If
 End If

End If

 Select Case k
  Case 3, 4, 5:
   ActiveDocument.Tables(t).Cell(j + 1, k).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
  Case 1, 2:
   ActiveDocument.Tables(t).Cell(j + 1, k).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
 End Select

 Next k
rs.MoveNext
Next j

Add code to place a page break for the next letter after code is executed for each Vendor ID.

 If Not rs.EOF Then
  rsRows = ActiveDocument.Paragraphs.Count
  Selection.Move Unit:=wdParagraph, Count:=rsRows
  Selection.InsertBreak Type:=wdPageBreak
 End If
End If

  rs.Close
  cn.Close

  Selection.MoveDown Unit:=wdLine, Count:=labelrows + 2
  Selection.TypeParagraph
  Selection.InsertBreak Type:=0

 End If

End Sub

Write code to have a Sub Macro that iterates through the 10 rows. By calling the sPrintTable code and passing the integer ID as the value for each page, a complete set of 10 letters will be generated in a single Word document.

Sub printAll()
 Dim i As Integer

  For i = 1 To 10
   sPrintTable (i)
  Next i

End Sub

MS Word Merged Letter with Varying Multiple Rows in Body

Image of Letter with 4 rows of data

Image of Letter with 2 rows of data

Image of Letter with 5 rows of data