Automating MailMerge to create MailingLabels - excel

Question

I am trying to create mailinglabels using mailmerge but automated from my excel file.
Basically, I already have a template saved down as a word doc. My macro populates the worksheet called "Box" with the data needed on the label. Once populated, it calls on another sub to initiate the MailMerge Procedure. My code is breaking right at the start of the MailMerge.
here is my code:
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
I am expecting the macro to open the specified word doc and import the data from the worksheet "box" but instead i get a
Run time error '91': Object variable or with block variable not set error

Answer 1

i found a better way of doing this, it is as follows:
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
however, this code still requires the user to pick the sheet within the datasource. Is there another way of choosing the sheet in the code so the user doesn't have to be involved at all? Specifically this line:
oDoc.Mailmerge.OpenDataSource sPath