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 & "'"

将“A”替换为实际列
将“客户”替换为列的实际标题

就像我在问题下面的评论中提到的那样，为什么要在循环中创建和销毁对象？您可以从For循环中实例化Word应用程序。你可以将它从For循环中删除。

这是你在尝试什么？（ 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

从Excel工作表中仅选择一行（作为邮件合并的一部分）

1 个答案: