Selecting only one row from a excel sheet (as part of mail merge)

Question

I am totally new to VBA and I am writing a code to mail merge data from each row in an excel sheet to a certain word document and save that document with name corresponding to the first cell value from each row.

Each row contains the information of a client. That is why I have to mailmerge each row info seperately.

So far the code works fine, but two problems I need to solve:

1) SQLStatement:="SELECT * FROMSheet1$" ends up mail merging info from all the rows in sheet during each iteration of the for loop (the loop iterates through each row). So what happens is that, each client's document includes data of other clients (excel rows) as well.

2) The usual automation error unless I keep the source word document open.

So can someone please tell me how to select the info from only the row where the iteration has reached.

I triedSQLStatement:="SELECT rw.row* FROMSheet1$" But it does not work

Any help would be good. The full code is:

Sub RunMerge()

'booking document begins here

Dim wd As Object
Dim wdocSource As Object
Dim activedoc
Dim strWorkbookName As String
Dim x As Integer
Dim cdir As String
Dim client As String

Dim sh As Worksheet
Dim rw As Range
Dim rowcount As Integer

Set sh = ActiveSheet
For Each rw In sh.Rows
    If sh.Cells(rw.Row, 1).Value = "" Then
        Exit For
    End If



cdir = "C:\Users\Kamlesh\Desktop\"
client = Sheets("Sheet1").Cells(rw.Row + 1, 1).Value
Dim newname As String
newname = "Offer Letter - " & client & ".docx"


On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Const wdFormLetters = 0, wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16

Set wdocSource = wd.Documents.Open("C:\Users\Kamlesh\Desktop\master\Regen-booking.docx")

strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

wdocSource.MailMerge.MainDocumentType = wdFormLetters

wdocSource.MailMerge.OpenDataSource _
        Name:=strWorkbookName, _
        AddToRecentFiles:=False, _
        Revert:=False, _
        Format:=wdOpenFormatAuto, _
        Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
        SQLStatement:="SELECT * FROM `Sheet1$`"

With wdocSource.MailMerge
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
End With

wd.Visible = True
wd.ActiveDocument.SaveAs cdir + newname
'wdocSource.Close SaveChanges:=False
'wd.Quit
Set wdocSource = Nothing
Set wd = Nothing


Next rw

End Sub

My Excel Sheet looks like this

Answer 1

Try this. Obviously this is untested as I do not know your header names and values

SQLStatement:="SELECT * FROM `Sheet1$` WHERE SomeField = 'SomeUniqueValue'"

Something like

SQLStatement:="SELECT * FROM `Sheet1$` WHERE Client = " & Range("A" & rw + 1).Value & "'"

1. Replace "A" by the actual column
2. Replace "Client" by the actual header of the column

Also like I mentioned in the comment below the question, why are you creating and destroying objects in the loop? You can instantiate the Word Application out of the For loop. And you can destroy it out of the For Loop.

Is this what you are trying? (UNTESTED)

Change sSQL = "SELECT * FROMSheet1$WHERE [Client Name] = '" & .Range("A" & i).Value & "'" in the below code as per your requirements.

Const wdFormLetters = 0, wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16

Sub RunMerge()
    Dim wd As Object, wdocSource As Object
    Dim sh As Worksheet
    Dim Lrow As Long, i As Long
    Dim cdir As String, client As String, newname As String
    Dim sSQL As String

    cdir = "C:\Users\Kamlesh\Desktop\"

    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then
        Set wd = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    Set wdocSource = wd.Documents.Open(cdir & "\master\Regen-booking.docx")
    Set sh = ActiveSheet
    strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name

    With sh
        Lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 2 To Lrow
            If Len(Trim(.Range("A" & i).Value)) <> 0 Then
                client = .Cells(i, 1).Value
                newname = "Offer Letter - " & client & ".docx"

                wdocSource.MailMerge.MainDocumentType = wdFormLetters

                '~~> Sample String
                sSQL = "SELECT * FROM `Sheet1$` WHERE [Client Name] = '" & .Range("A" & i).Value & "'"

                wdocSource.MailMerge.OpenDataSource Name:=strWorkbookName, _
                AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatAuto, _
                Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
                SQLStatement:=sSQL

                With wdocSource.MailMerge
                    .Destination = wdSendToNewDocument
                    .SuppressBlankLines = True
                    With .DataSource
                        .FirstRecord = wdDefaultFirstRecord
                        .LastRecord = wdDefaultLastRecord
                    End With
                    .Execute Pause:=False
                End With

                wd.ActiveDocument.SaveAs cdir & newname
                wd.ActiveDocument.Close SaveChanges:=False
            End If
        Next i
    End With

    wdocSource.Close SaveChanges:=False
    wd.Quit

    Set wdocSource = Nothing
    Set wd = Nothing
End Sub