combine multiple records into a single mailmerge

bluetongue

Registered User.
Local time
Tomorrow, 02:58
Joined
Jul 15, 2004
Messages
34
The code below shows how to create a mailmerge datasource to include details from several records in a single letter.

Code:
Option Compare Database
Option Explicit

Sub createMailMergeData()
' an MSWord mailmerge will create a new document from each record
' this code combines multiple records into a single record so that the
' repeated groups are formatted as a tabbed list in the mailmerge document.
'
' combine multiple records into a single mailmerge
' requires an empty table called tblMailMerge with the following fields:
'   Company ID      long integer
'   CompanyName     text
'   addressLine1        text
'   addressLine2        text
'   townStatePC     text (town, state and postcode)
'   Products            memo
'
' create a query to select the records required
' include in the SQL the ORDER BY clause
'   ORDER BY CompanyID, PRODUCTID
'   to force all company records to be consecutive
'
' the CompanyID,Name and address fields are stored in variables
' while the memo field combines ProductID and ProductName with tab and line feed characters
' a new record is written to tblMailMerge when the CompanyID changes
'
' Author: bluetongue
'
Dim dbThis As Database
Dim rsIn As Recordset
Dim rsOut As Recordset
Dim lngCompanyID As Long
Dim strCompanyName As String
Dim strAddressLine1 As String
Dim strAddressLine2 As String
Dim strTownStatePC As String
Dim strProducts As String

Set dbThis = CurrentDb
Set rsIn = dbThis.OpenRecordset("qryInputs", dbOpenDynaset, dbReadOnly)
    rsIn.MoveLast
    rsIn.MoveFirst
Set rsOut = dbThis.OpenRecordset("tblMailMerge")

Do While Not rsIn.EOF
    With rsIn
    If lngCompanyID <> .Fields("CompanyID") Then
        With rsOut
            .AddNew
            .Fields("CompanyID") = lngCompanyID
            .Fields("Sponsor Name") = strCompanyName
            .Fields("Address Line1") = strAddressLine1
            .Fields("Address Line2") = strAddressLine2
            .Fields("townStatePC") = strTownStatePC
            .Fields("Products") = strProducts
            If lngCompanyID <> 0 Then
                .Update
            End If
        End With
        lngCompanyID = .Fields("CompanyID")
        strCompanyName = .Fields("Sponsor Name")
        strAddressLine1 = .Fields("Address Line1")
        strAddressLine2 = Nz(.Fields("Address Line2"))
        strTownStatePC = .Fields("townStatePC")
        strProducts = .Fields("PRODUCTID") & Chr(9) & .Fields("ARTGLabelName")
    Else
        strProducts = strProducts & Chr(13) & .Fields("PRODUCTID") & Chr(9) & .Fields("ARTGLabelName")
    End If
        .MoveNext
    End With
Loop
' process last record
    With rsOut
        .AddNew
        .Fields("CompanyID") = lngCompanyID
        .Fields("Sponsor Name") = strCompanyName
        .Fields("Address Line1") = strAddressLine1
        .Fields("Address Line2") = strAddressLine2
        .Fields("townStatePC") = strTownStatePC
        .Fields("Products") = strProducts
        .Update
    End With

Set rsIn = Nothing
Set rsOut = Nothing
Set dbThis = Nothing
End Sub
 
It works a treat!
Thank you so much for sharing.
Regards
Julie
 

Users who are viewing this thread

Back
Top Bottom