Option Explicit
Dim objWord As Object, oDoc As Object, oDoc2 As Object
Dim myPath As String, fName As String, StrSrc As String
Const wdSendtToNewDocument = 0
Const wdSendToPrinter = 1
Const wdFormLetters = 0
Const wdDirectory = 3
Const wdNotAMergeDocument = -1
Const wdMergeSubTypeAccess = 1
 
Sub Merge()
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    fName = "u:\Sports13\Reports\FR\v8\" & Worksheets("Front").Range("I14")
    Set oDoc = objWord.Documents.Open(Filename:=fName, ConfirmConversions:=False, _
        ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
    StrSrc = ThisWorkbook.FullName
    With oDoc
        With .MailMerge
            .MainDocumentType = wdFormLetters
            .OpenDataSource _
              Name:=StrSrc, ReadOnly:=True, AddToRecentFiles:=False, LinkToSource:=False, _
              Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
                "Data Source=StrSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
                SQLStatement:="SELECT * FROM `CONTROL_1$`", _
                SQLStatement1:="", SubType:=wdMergeSubTypeAccess
            .Destination = wdSendtToNewDocument
            .SuppressBlankLines = True
            With .DataSource
              .FirstRecord = 1
              .LastRecord = .RecordCount
            End With
            .Execute Pause:=False
            .MainDocumentType = wdNotAMergeDocument
        End With
        .Close False
    End With
    Set oDoc2 = objWord.ActiveDocument
    myPath = "u:\Sports13\Workorders\" & Format(Worksheets("varhold").Range("A1"), "ddd dd-mmm-yy")
    If Len(Dir(myPath, vbDirectory)) = 0 Then MkDir myPath
    oDoc2.SaveAs myPath & "\" & (Worksheets("varhold").Range("A46").Value & "docx")
    AppActivate "Microsoft Excel"
    Set oDoc = Nothing: Set oDoc2 = Nothing: Set objWord = Nothing
End Sub