Sub Merge2()
    Dim wshfront As Worksheet
    Set wshfront = Worksheets("Front")
    itype = Worksheets("Front").Range("E12")
    isubresp = Worksheets("Front").Range("G12")
 
    Unload UserForm4
 
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
 
    itype = Worksheets("varhold").Range("W1")
 
    If itype = "DR" Then
        fName = "u:\Sports13\Reports\DR\v9\DRv9.docx"
    ElseIf itype = "DT" Then
        MsgBox "Report not created"
        'fName = "u:\Sports13\Reports\DR\v9\" & Worksheets("Front").Range("I14")
    ElseIf itype = "FR" Then
        fName = "u:\Sports13\Reports\FR\v9\FRv9.docx"
    ElseIf itype = "FT" Then
        MsgBox "Report not created"
        'fName = "u:\Sports13\Reports\DR\v9\" & Worksheets("Front").Range("I14")
    ElseIf itype = "CR" Then
        MsgBox "Report not created"
        'fName = "u:\Sports13\Reports\DR\v9\" & Worksheets("Front").Range("I14")
    Else
        MsgBox "Report not created"
        'fName = "u:\Sports13\Reports\DR\v9\" & Worksheets("Front").Range("I14")
    End If
 
    Set oDoc = objWord.Documents.Open(Filename:=fName, ConfirmConversions:=True, _
        ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
    StrSrc = ThisWorkbook.FullName
    'MsgBox StrSrc
    With oDoc
        With .MailMerge
            .MainDocumentType = wdDirectory
            .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$` WHERE [Type$]='" & itype & "' AND [SubResp]= '" & isubresp & "' ORDER BY [Start] ASC, [Facility B$] ASC, [Unit$] ASC", _
                SQLStatement1:="", SubType:=wdMergeSubTypeAccess
            If Worksheets("varhold").Range("V1") = "Edit" Then
               .Destination = wdSendtToNewDocument
           Else
               .Destination = wdSendToPrinter
           End If
            .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

Sub proceed23()
 
    'Written by Trebor76
    'Visit my website www.excelguru.net.au
 
    Dim strWrkSheetArray() As String 'Declares a dynamic array variable to hold the relevant sheet tabs.
    Dim intArrayCount As Integer
    Dim varWrkSheet As Variant
    Dim rngCell As Range
 
    For Each rngCell In Worksheets("varhold").Range("T3:T10")
        If Len(rngCell) > 0 Then
            intArrayCount = intArrayCount + 1
            ReDim Preserve strWrkSheetArray(1 To intArrayCount) 'Copy elements from the existing array to the new array
            strWrkSheetArray(intArrayCount) = Left(CStr(rngCell), 31) 'Maximum length of a tab is 31.
        End If
    Next rngCell
 
    If intArrayCount = 0 Then
        MsgBox "Nothing has been assigned to array. Check your data and try again."
        Exit Sub
    End If
 
    'Ark68, this is just to show how to use the 'strWrkSheetArray' variable
    For Each varWrkSheet In strWrkSheetArray
        Worksheets("varhold").Range("W1") = Right(varWrkSheet, 2)
        UserForm4.TextBox2.Value = varWrkSheet
        UserForm4.Show
        'MsgBox varWrkSheet
    Next varWrkSheet
 
End Sub