从excel工作表中选择只有一行（作为邮件合并的一部分）

Question

我完全是VBA的新手，我正在编写一个代码，用于将excel工作表中每行的合并数据发送到某个word文档并保存该文档名称对应于每行的第一个单元格值。

每一行都包含客户端的信息。这就是为什么我必须单独邮寄每行信息。

到目前为止，代码工作正常，但有两个问题，我需要解决：

1）SQLStatement:="SELECT * FROM工作表Sheet1 $ " 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 SomeField = 'SomeUniqueValue'" 

喜欢的东西

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

1. 由实际列将“A”
2. 通过实际替换“客户端”列的标题

也就像我在下面的评论中提到的问题，为什么你创建一个nd破坏循环中的对象？您可以从For循环中实例化Word应用程序。你可以从For Loop中销毁它。

这是你正在尝试？ （UNTESTED）

更改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