MailMerge: из Excel в Word Сохранение отдельных документов для каждой записи с сохранением ссылки на источник

Question

Во-первых, я хочу сказать, что я чрезвычайно новичок в использовании VBA для повышения эффективности своих листов Excel.

Я начал несколько месяцев назад и в основном генерировал код, соединяя воедино то, что я нахожу в Интернете, а затем редактирую, чтобы соответствовать мои конкретные c потребности.

Что делает текущий код:

То, что я создал, позволяет мне выполнять многократное почтовое слияние документов из Excel для объединения записей из моего источника данных (Информация о проекте) с щелчок кнопки. Перед выполнением слияния пользователь определяет 5 условий:

1. Зонирование (например, R20; находится в ячейке C8)
2. Тип смягчения (например, TE; расположен в ячейке F8)
3. Шаблон для использования из ранее загруженного списка шаблонов (находится в ячейке J8)
4. Площадь лота (расположен в ячейке P8)
5. Если это справедливая компенсация Отчет («да» или «нет», расположенный в ячейке C11)

Приведенные выше критерии определяют номера записей, соответствующие указанным критериям, для создания отдельных документов mailmerge для каждой записи и сохраняются в соответствующем файле свойств. который связан с номером записи. Лист, который генерирует mailmerge («Создание отчета»), отличается от источника данных и содержит записи о том, когда выполнялось mailmerge и какой шаблон использовался. Этот лист также содержит список записей и является диапазоном поиска для критериев (начало записи в строке 39, поэтому +37 используется для соответствия строке «Создание отчета»). Код также содержит полосу загрузки, которая появляется, когда происходит слияние выполнено и показывает процент завершения (процент неверен, но используется больше, чтобы показать, что выполняется слияние пользователей).

Мой вопрос:

То, что я сейчас пытаюсь настроить, - это когда выполняется mailmerge Мне все еще нужны отдельные документы, но я хочу сохранить связь между новым документом и источником данных. Таким образом, я всегда могу обновить слово документ, если произойдут какие-либо изменения. В настоящее время он сливается с текстовым документом, который больше не содержит поля mailmerge и выглядит так, как будто я завершил слияние.

Я предполагаю, что это незначительное изменение после .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 для каждого выходного документа.

Альтернативным подходом будет повторный запуск mailmerge только для тех записей, которые вы хотите обновить .