Автоматизация MailMerge для создания MailingLabels

Question

Я пытаюсь создать mailinglabels, используя mailmerge, но автоматически из моего файла Excel. В принципе, у меня уже есть шаблон, сохраненный как слово do c. Мой макрос заполняет лист «Box» данными, необходимыми для метки. После заполнения он вызывает другую подпрограмму для запуска процедуры MailMerge. Мой код ломается прямо в начале MailMerge.

вот мой код:

Option Explicit

Sub CreateBox()

Dim LastRow As Long
Dim N As Integer
Dim nLastRow As Long
Dim nFirstRow As Long
Dim r As Range

LastRow = Track.Range("A" & Rows.Count).End(xlUp).Row

    Set r = Track.UsedRange
    nFirstRow = 2

Dim i As Long: i = 2

With ActiveSheet
    On Error Resume Next
    Application.ScreenUpdating = False

    For N = nFirstRow To LastRow
        If .Cells(N, "X") = "N" Then
            .Cells(N, "B").Copy
             Worksheets("Box").Cells(i, "A").PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
             .Cells(N, "X").Value = "Y"
            .Cells(N, "D").Copy
             Worksheets("Box").Cells(i, "B").PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
            .Cells(N, "F").Copy
             Worksheets("Box").Cells(i, "C").PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
            .Cells(N, "E").Copy
             Worksheets("Box").Cells(i, "D").PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
            .Cells(N, "A").Copy
             Worksheets("Box").Cells(i, "E").PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
            .Cells(N, "T").Copy
             Worksheets("Box").Cells(i, "F").PasteSpecial Paste:=xlPasteValues
             Application.CutCopyMode = False
            i = i + 1
        End If
    Next
End With

Call mbrMailMerge

End Sub

Sub mbrMailMerge()
Dim Sheet As Worksheet, wsName As String, N As Long, dataSrc As String
Dim wdApp As New Word.Application, wdDoc As Word.Document
dataSrc = ActiveWorkbook.FullName
Const hDir As String = "C:\Users\nparker\Documents\Personal - NML\VLS" 'update filepath
wdApp.DisplayAlerts = wdAlertsNone

For N = 2 To Sheets.Count
    wsName = Box.Name
    Select Case wsName
    Case "Box"
        Set wdDoc = wdApp.Documents.Open(hDir & dataSrc & wsName & ".docx", AddToRecentFiles:=False)
        Call Mailmerge(wdDoc, dataSrc, wsName)
    Case Else
        MsgBox "Could not find " & wsName & " Member Word Doc for Mail Merge. Please complete manually.", vbExclamation
    End Select
Next
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Visible = True
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

Sub Mailmerge(wdDoc As Word.Document, dataSrc As String, wsName As String)

dataSrc = ActiveWorkbook.FullName

With wdDoc
    With .Mailmerge
        .MainDocumentType = wdMailingLabels
        .OpenDataSource Name:=dataSrc, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
        WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
        Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=dataSrc;Mode=Read;" & _
        "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & wsName & "$`", SQLStatement1:=""
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
            .Execute Pause:=False
            .Destination = wdSendToNewDocument
        End With
        .Close SaveChanges:=False
    End With
End Sub

.

With wdDoc
 With .Mailmerge  '<-----my code is breaking on this line

Я ожидаю, что макрос откроет указанное слово сделать c и импортировать данные из «окна» рабочего листа, но вместо этого я получаю

Ошибка времени выполнения '91': переменная объекта или с переменной блока не установлена ​​ошибка

Answer 1

Я нашел лучший способ сделать это следующим образом:

Sub LabelMerge()

   Dim oWord As Word.Application, oDoc As Word.Document
   Dim sPath As String, I As Integer, oHeaders As Range
   Dim LastCol As Long

Application.ScreenUpdating = False

LastCol = Rear.Cells(1, Columns.Count).End(xlToLeft).Column

   Set oHeaders = Rear.Range(Rear.Cells(1, 1), Rear.Cells(1, LastCol))
   sPath = ThisWorkbook.FullName
   Set oWord = CreateObject("Word.Application")
   Set oDoc = oWord.Documents.Add
   oWord.Visible = True
   oDoc.Mailmerge.MainDocumentType = wdMailingLabels
   oWord.MailingLabel.CreateNewDocumentByID LabelID:="1359804772", _
        Address:="", AutoText:="ToolsCreateLabels1", LaserTray:= _
        wdPrinterManualFeed, ExtractAddress:=False, PrintEPostageLabel:=False, _
        Vertical:=False
   oDoc.Activate

   With oDoc.Mailmerge.Fields

     For I = 1 To oHeaders.Columns.Count
        If oHeaders.Cells(1, I).Text = "Harvest Date 1" Then
            oWord.Selection.TypeText Text:="H: "
            .Add oWord.Selection.Range, Name:="Harvest_Date_1"
            oWord.Selection.TypeText Text:="     J: "
        ElseIf oHeaders.Cells(1, I).Text = "Julian Date 1:" Then
            .Add oWord.Selection.Range, Name:="Julian_Date_1"
            oWord.Selection.TypeParagraph
            oWord.Selection.TypeText Text:="P: "
        ElseIf oHeaders.Cells(1, I).Text = "Package Date" Then
            .Add oWord.Selection.Range, Name:="Package_Date"
            oWord.Selection.TypeText Text:="     T: "
        ElseIf oHeaders.Cells(1, I).Text = "Team" Then
            .Add oWord.Selection.Range, Name:="Team"
            oWord.Selection.TypeParagraph
            oWord.Selection.TypeText Text:="CBI ITEM CODE: "
        ElseIf oHeaders.Cells(1, I).Text = "Product Code:" Then
            .Add oWord.Selection.Range, Name:="Product_Code"
       End If
       oWord.Selection.TypeText " "
     Next I
    oWord.Selection.WholeStory
    oWord.Selection.ParagraphFormat.LineSpacing = LinesToPoints(33008)
   End With

   oDoc.Mailmerge.OpenDataSource sPath
   oWord.WordBasic.mailmergepropagatelabel
   oDoc.Mailmerge.ViewMailMergeFieldCodes = False
   oDoc.ActiveWindow.View.ShowFieldCodes = False

   Set oDoc = Nothing
   Set oWord = Nothing

   Application.ScreenUpdating = True

   End Sub

однако, этот код все еще требует, чтобы пользователь выбрал лист в источнике данных. Есть ли другой способ выбора листа в коде, чтобы пользователь вообще не был вовлечен? В частности, эта строка: oDo c .Mailmerge.OpenDataSource sPath