MailMerge：从 Excel 到 Word 为每条记录保存单个文档，同时保持到源的链接

Question

首先我想说我对使用 VBA 来提高我的 Excel 工作表效率非常陌生。

几个月前我就开始了，主要是通过拼凑我在网上找到的内容然后进行编辑以满足我的特定需求来生成代码。

当前代码的作用：

我创建的内容允许我通过单击按钮从 excel 执行多文档邮件合并，以合并我的数据源（项目信息）中的记录。在执行合并之前，用户确定了 5 个条件；

1. 分区（例如 R20；位于单元格 C8）
2. 地役权类型（例如 TE；位于单元格 F8）
3. 之前上传的模板列表中要使用的模板（位于单元格 J8 中）
4. 地块区域（位于单元格 P8）
5. 如果是公正的补偿报告（“是”或“否”位于单元格 C11）

上述标准识别与指定标准匹配的记录号，为每条记录创建单独的邮件合并文档，并保存在与记录号关联的相应属性文件中。生成邮件合并（“报告创建”）的工作表与数据源不同，并维护执行邮件合并的时间和使用的模板的记录。此表还包含记录列表，并且是条件的搜索范围（记录开始于第 39 行，因此 +37 用于匹配“报告创建”行）。代码还包含一个加载栏，在合并时出现执行并显示完成百分比（百分比不正确，但用于显示用户合并正在进行中）。

我的问题：

我现在要调整的是当执行邮件合并时，我仍然想要单个文档，但我想维护新文档和数据源之间的链接。这样，如果发生任何更改，我总是可以更新 word 文档。它目前合并到一个不再包含任何邮件合并字段的 word 文档，就像我完成了合并一样。

我假设这是 .opendatasource 之后的一个小改动，但无法确定要更改的内容。

我的代码可能有点乱，当然可以进行一些清理，但它可以完成工作。见下文。

当前代码：

Sub RunMerge()

Dim StrMMSrc As String, StrMMDoc As String, StrMMDocName As String, StrName As String, dataname As String  
Dim i As Long  
Dim Load As Integer  
Dim wdApp As New Word.Application  
Dim wdDoc As Word.Document  
Dim ReportNum, AddressName, SaveLoc, NewFile, fpath, subfldr, DateCr As String  
Dim ExpTemp, ExTempDate, ExpReview, ExpRevDate As Range  
Dim ExpRow, CustCol, lastRow, StrMMDocRow, ExportedDoc, LotSizeSM, LotSizeLG, ActualLS, symbpos As Long  
Dim FileName, Zoning, Ease, LotSizeRNG, Ztype, Etype As String  

On Error GoTo errhandler

'Turn off at the start
TurnOffFunctionality
wdApp.DisplayAlerts = wdAlertsNone


Set wsreports = ThisWorkbook.Worksheets("Report Creation")  
Set wsinfo = ThisWorkbook.Worksheets("Project Information")  
Set wsdetails = ThisWorkbook.Worksheets("Project Details")  
StrMMSrc = ThisWorkbook.fullname  
lastRow = wsinfo.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows,   LookIn:=xlValues).row  

    dataname = wsinfo.Name  

    'set folder path for saving documents  
    fpath = ThisWorkbook.Sheets("Project Details").Range("E30").Value  
    subfldr = wsdetails.Range("F34").Value  

    'date exported  
    DateCr = Format(Date, "mm-dd-yyyy")  

ExportedDoc = 0


With wsreports


    ' set range criteria  
    LotSizeRNG = .Range("P8").Value  
    symbpos = InStr(1, LotSizeRNG, "<>")  

    LotSizeSM = CInt(Left(LotSizeRNG, symbpos - 1))  
    LotSizeLG = CInt(Mid(LotSizeRNG, symbpos + 2))  

If LotSizeLG = "" Then LotSizeLG = 100000000

    If wsreports.Range("J8").Value = Empty Then  
        MsgBox "Please Select A Template From The Dropdown List to Export"  
        wsreports.Range("J8").Select  
        GoTo errhandler  
    End If  

    StrMMDocRow = .Application.Match(Range("J8").Value, .Range("C1:C34"), 0) 'Set Template Row  
    StrMMDocName = .Range("J8").Value 'set template name  
    Zoning = .Range("C8").Value 'set Zoning Criteria  
    Ease = .Range("F8").Value 'Set Easement Criteria  
    StrMMDoc = .Range("AB" & StrMMDocRow).Value 'Word Document Filename  

End With  

wdApp.Visible = False  

Set wdDoc = wdApp.Documents.Open(FileName:=StrMMDoc, AddToRecentFiles:=False)  

With wdDoc  

    With .MailMerge  
            .MainDocumentType = wdFormLetters  
            .OpenDataSource Name:=StrMMSrc, AddToRecentFiles:=False, LinkToSource:=False,  
 ConfirmConversions:=False, _  
                    ReadOnly:=True, Format:=wdOpenFormatAuto,   Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _  
                    "User ID=Admin;Data Source=" & StrMMSrc & ";Mode=Read;Extended   Properties=""HDR=YES;IMEX=1;"";", _  
                    SQLStatement:="SELECT * FROM `Project Information$`", SQLStatement1:="",   SubType:=wdMergeSubTypeAccess  

    UserFormLoad.Show  

    For i = 2 To lastRow  

        Ztype = wsreports.Range("D" & i + 37).Value  
        Etype = wsreports.Range("F" & i + 37).Value  
        ActualLS = wsreports.Range("E" & i + 37).Value  

        'Check the row for matching zone and easement cristeria  
        If wsreports.Range("C11").Value = "No" And StrMMDocName <> wsreports.Range("H" & i + 37).Value _  
            And Ztype = Zoning And ActualLS >= LotSizeSM And ActualLS <= LotSizeLG And Etype = Ease Then    

            ExportedDoc = ExportedDoc + 1  

            'set newfile location  
            ReportNum = wsreports.Range("B" & i + 37).Value  
            AddressName = wsreports.Range("C" & i + 37).Value  
            SaveLoc = fpath & "\#" & ReportNum & "_" & AddressName & "\" & subfldr  

            'generate new file name with date  
            NewFile = SaveLoc & "\" & AddressName & "_Draft Report_" & DateCr & ".docx"  

            .Destination = wdSendToNewDocument  
            .SuppressBlankLines = True  

                With .DataSource  
                    .FirstRecord = i - 1  
                    .LastRecord = i - 1  
                    .ActiveRecord = i - 1    
                    StrName = NewFile  
                End With  

                .Execute Pause:=False  

                wsreports.Range("I" & i + 37).Value = StrMMDocName  
                wsreports.Range("L" & i + 37).Value = DateCr  

                With wdApp.ActiveDocument  
                    .SaveAs FileName:=StrName, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False  
                    ' and/or:  
                    '.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False  
                    .Close savechanges:=False  
                End With  


            Dim r As Integer  

            r = i  

            Load = Application.WorksheetFunction.RoundDown((r + 1) / (lastRow) * 100, 0)  
            DoEvents  
            UserFormLoad.LoadBar.Width = Load / 100 * 222  
            UserFormLoad.LabelProg.Caption = Load & "%"  

            End If  

        Next i  

        Unload UserFormLoad  

        .MainDocumentType = wdNotAMergeDocument  
    End With  
    .Close savechanges:=False  
End With  

If ExportedDoc = 0 Then  
MsgBox "No Properties Matched The Criteria Specified. Use The Table To Verify The Easement and Zoning   Have Properties Meeting Criteria.", vbOKOnly, "No Matches Found"  
Else  
MsgBox "The Property Draft Reports Were Exported Successfully. Please Check Project Property" & subfldr &  " Folder for Word Document.", vbOKOnly, "Export Successfull"
End If  

'cleanup if error  
errhandler:  
    TurnOnFunctionality  
    wdApp.DisplayAlerts = wdAlertsAll  

    Set wdDoc = Nothing  
    Set wdApp = Nothing  

End Sub

Answer 1

您不能将 mailmerge 用于您想要实现的目标。您需要使用 LINK 字段而不是 MERGEFIELD，并更新每个输出文档的 LINK 字段行引用。

另一种方法是仅针对要更新的记录重新运行邮件合并。