Excelシートから1行のみを選択する（差し込み印刷の一部として）

Question

私はVBAを全く新しくしています。Excel文書の各行から特定の単語文書に差し込みデータをコードして保存します名前は各行からの最初のセル値に対応します。

各行にはクライアントの情報が含まれています。そのため、私は各行の情報を別々にメールに差し替える必要があります。

これまでのコードは正常に動作しますが、二つの問題は私が解決する必要があります（

1）SQLStatement:="SELECT * FROMシート1は$ "は、forループの各反復の間にシート内のすべての行からのメールマージ情報を終わりますループは各行を繰り返す）。つまり、各クライアントのドキュメントには他のクライアントのデータ（Excelの行）も含まれています。

2）ソースワードドキュメントを開いたままにしない限り、通常の自動化エラーです。

誰かが、反復に達した行からのみ情報を選択する方法を教えてください。

私はSQLStatement:="SELECT rw.row* FROMのSheet1に$ "を試してみました。しかし、それは

動作しないすべてのヘルプは良いでしょう。 完全なコードは次のとおりです。

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 

私のExcelシートは、これを試してみてください。この

Answer 1

のように見えます。もちろん、私はあなたのヘッダ名を知らないので、これはテストされていないと

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

1. よう

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

   何かが実際の列

2. で「A」を置き換えれる値の実際で「クライアント」を交換してください列のヘッダー

また、質問の下のコメントに記載されているように、なぜあなたはループ内のオブジェクトを破壊しますか？ ForループからWordアプリケーションをインスタンス化できます。そして、あなたはForループからそれを破壊することができます。

これはあなたの試みですか？ （未検査）

sSQL = "SELECT * FROM Sheet1 $ WHERE [Client Name] = '" & .Range("A" & i).Value & "'"をご使用の要件に従って変更してください。

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