Keeping Focus on One Worksheet

[Ark68]

I have an Excel VBA project in which I wish to maintain "focus" on the main worksheet of the workbook, "DYNAMIC"

At one point in my application, a button on a userform launches this code:

    Application.DisplayAlerts = False
    With Workbooks.Add
        .SaveAs Filename:=path2 & "\" & ws_name
        Set wksh_book = Workbooks(ws_name)
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    
    With ws_servicewksh
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Services"
        Set ws_wkservices = wksh_book.Worksheets("Services")
    End With
    with ws_masterwksh
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Master"
        Set ws_wkmaster = wksh_book.Worksheets("Master")
    End With
    Application.ScreenUpdating = True

    With ws_wkmaster
    ... more code

This portion of the code in workbook1 creates a new workbook (workbook2), copies worksheets between the two open workbooks, and proceeds to work with the worksheets in workbook2.

How can I maintain the focus on workbook1 worksheet ("DYNAMIC") while the code is being executed. I don't need nor want the user to have to watch the background processes. I tries to use screenupdating, but it isn't doing what I thought it would.

Suggestions?

 

[Ark68]

I have added a watch for application.screenupdating .

It is true prior to...

Application.ScreenUpdating = False

And remains false until

[code]Application.ScreenUpdating = true

The focus changes from my user front worksheet (DYNAMIC) to the new workbook at:

With Workbooks.Add

 

[Macropod]

You probably don't need either of the Application.DisplayAlerts lines and the Application.ScreenUpdating = False should be where your Application.DisplayAlerts = False now is. As for the Application.ScreenUpdating = True line, that should probably be at the very end of your code.

 

[Ark68]

Hi Paul, thank you for chiming in.

You probably don't need either of the Application.DisplayAlerts lines

I'm relying on them to surpress the "This file exists do you wish to replace" prompt. I simply wish to overwrite the file and don't require the interfering prompt.

In testing though, I took it them out which left application.screenupdating=false in essence where application.displayalerts=false was. The application.screenupdating=true is at the very end of my procedure.

Sub master_worksheet()
    
    Application.ScreenUpdating = False
    
    'Application.DisplayAlerts = False
     With Workbooks.Add
        .SaveAs Filename:=path2 & "\" & ws_name
        Set wksh_book = Workbooks(ws_name)
    End With
    'Application.DisplayAlerts = True

    With ws_servicewksh                                     'create services worksheet
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Services"
        Set ws_wkservices = wksh_book.Worksheets("Services")
    End With
    
    With ws_masterwksh                                      'create master worksheet
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Master"
        Set ws_wkmaster = wksh_book.Worksheets("Master")
    End With

    With wksh_book
        Application.DisplayAlerts = False
        On Error Resume Next
        .Sheets("Sheet1").Delete
        .Sheets("Sheet2").Delete
        .Sheets("Sheet3").Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
    End With
    
    With ws_wkmaster
    ... more code ...
    End With

    Application.ScreenUpdating = True

End Sub

Still switching to the new workbook upon adding it.

 

[Macropod]

You could try something along the lines of:

Sub master_worksheet()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Dim wksh_book As Workbook
  Set wksh_book = Workbooks.Add
  wksh_book.Windows(1).Visible = False
  'Do all your processing here
  wksh_book.SaveAs Filename:=path2 & "\" & ws_name
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  wksh_book.Windows(1).Visible = True
End Sub

You seem to be using all manner of undeclared variables. You really should declare all your variables - and use Option Explicit - to trap compilation errors. As you'll see from my code, you can also set the object references when the objects are created.

 

[Ark68]

Thanks Paul,

I've adapted my application with the code you kindly provided me and it appears to have accomplished the issue of the original post.

But now I'm getting an error with the line in red. "Cannot rename a sheet to the same name as another sheet...". It appears the new sheet is being added to the same workbook as it's source. The source is in workbook sports15b.xlsm, worksheet Services, and is referenced in the code as ws_serviceswksh. It is supposed to be copied over to the workbook just created. It had worked when the new workbook was the active workbook. I anticipate having similar problems as I move on through this procedure.

You seem to be using all manner of undeclared variables. You really should declare all your variables - and use Option Explicit - to trap compilation errors

I have learned this lesson long ago and I assure you I do both ... I just hadn't included it in my original post. This time around, I'll post the entire procedure.

Option Explicit
Sub master_worksheet()

    Dim wb_base As Workbook, wksh_book As Workbook, newbook As Workbook, trgt_wksh As Worksheet, ka As Worksheet
    Dim ws_core As Worksheet, ws_corestaff As Worksheet
    Dim ws_masterwksh As Worksheet, ws_vh As Worksheet, ws_wkmaster As Worksheet, ws_servicewksh As Worksheet, ws_wkservices As Worksheet
    Dim qfile2 As String, st_srchfn As String, fac5 As String, crew_sig As String, crew_prep As String, crew_groom As String, crew_lon As String, crew_loff As String, crew_close As String
    Dim dir_name As String, path2 As String, ws_name As String, pristaff
    Dim norec As Long, rws2add As Long, i As Long, y As Long, SR As Long, lrow As Long, base_row As Double
    Dim r As Range, fac_rng As Range, r_body As Range, c As Range, rcore As Range, rdata As Range
    Dim CList(1 To 7) As String, sReport(1 To 8) As String, arr2, arr4
    Dim s_rpt As String, rng_body As Range, cell As Range, s_crew As String, s_crew_name As String, s_crew2 As String, s_crew_name2 As String
    Dim llastrow As Long, x As Long, no_srvs As Long, row_no As Long, dt_rid As Long, dt_rid_row As Long, rw_start
    Dim srv_cln As Long, ref_cm As Long, jl As Long, cntr As Long, d As Range, h As Long
    Dim l_adj_crew As String, r_adj_crew As String, ll As String, s_sdd As String
    Dim tg_RID As Long, l_clm As Long, r_clm As Long, src_RID_row As Long, l_clm_val As String, r_clm_val As String, lcolm As Long
    Dim prp_type As String, dts_div As String, dts_lwr As String, dts_upr As String, ka2 As String
    Dim cm As Long, u As Long
    Dim RID As Long, fma_row As Long, j As Long
    Dim vParts
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    sReport(1) = "CUE"
    sReport(2) = "CUL"
    sReport(3) = "HPE"
    sReport(4) = "HPL"
    sReport(5) = "RPE"
    sReport(6) = "RPL"
    sReport(7) = "WPE"
    sReport(8) = "WPL"
    
    Set ws_masterwksh = Workbooks("sports15b.xlsm").Worksheets("MasterWKSH")
    Set ws_servicewksh = Workbooks("sports15b.xlsm").Worksheets("ServicesWKSH")
    Set ws_vh = Workbooks("sports15b.xlsm").Worksheets("VAR_HOLD")
    Set fac_rng = Workbooks("Sports15b.xlsm").Worksheets("Facilities").Range("A:G")
    
    qfile2 = ws_vh.Range("B4")
    
    st_srchfn = "H:\PWS\Parks\Parks Operations\Sports\Sports15\DATA1\" & qfile2
    
    dir_name = Format(ws_vh.Range("B2"), "ddd dd-mmm-yy")
    path2 = "H:\PWS\Parks\Parks Operations\Sports\Sports15\WORKORDERS\" & dir_name
    ws_name = "WS " & Format(ws_vh.Range("B2"), "dd-mmm-yy") & ".xlsx"
    
    On Local Error Resume Next
    MkDir path2
    
    'Select Case Err.Number
    '    Case 0
    '        MsgBox "created directory"
        'Case 75
    '        MsgBox "Directory already exists"
    '    Case Else
    '        MsgBox Err.Number & " -" & Err.Description
    'End Select
    
    vParts = Split(st_srchfn, "\")
    On Error Resume Next
    Set wb_base = Workbooks(vParts(UBound(vParts)))
    If Err.Number Then Set wb_base = Workbooks.Open(st_srchfn)
    On Error GoTo 0
    
    On Error Resume Next
    Windows(wb_base.Name).Visible = False
    On Error GoTo 0
    Set ws_core = wb_base.Worksheets("CORE")
    Set ws_corestaff = wb_base.Worksheets("Staff")

    norec = WorksheetFunction.Count(ws_core.Range("C:C"))   'last row in source (ws_core)
    Set rcore = ws_core.Range("A2:EE" & norec + 1)          'source range (ws_core)
    
    Set wksh_book = Workbooks.Add
    wksh_book.Windows(1).Visible = False
    wksh_book.SaveAs Filename:=path2 & "\" & ws_name
    
    'Application.DisplayAlerts = False
    'With Workbooks.Add
    '    .SaveAs Filename:=path2 & "\" & ws_name
    '    Set wksh_book = Workbooks(ws_name)
    'End With
    'Application.DisplayAlerts = True

    With ws_servicewksh                                     'create services worksheet
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Services"
        Set ws_wkservices = wksh_book.Worksheets("Services")
    End With
    
    With ws_masterwksh                                      'create master worksheet
        .Copy After:=Sheets(Sheets.Count)
        ActiveSheet.Name = "Master"
        Set ws_wkmaster = wksh_book.Worksheets("Master")
    End With
    
    With wksh_book
        On Error Resume Next
        .Sheets("Sheet1").Delete
        .Sheets("Sheet2").Delete
        .Sheets("Sheet3").Delete
        On Error GoTo 0
    End With
    
    With ws_wkmaster                                        'build master worksheet
        .Range("M1") = ws_vh.Range("B2")
        .Range("M4") = "Min Time"
        .Range("O4") = "ALL"
        .Range("P4") = "Max Time"
        .Range("M5") = Format(WorksheetFunction.min(ws_core.Range("O:O")), "h:mmA/P")
        .Range("P5") = Format(WorksheetFunction.Max(ws_core.Range("O:O")), "h:mmA/P")
       'insert blank rows
        rws2add = norec - 1
        Set r = .Range("A13")
        Do
            .Range(r.offset(1, 0), r.offset(rws2add, 0)).EntireRow.Insert
            Set r = Cells(r.row + rws2add + 1, 1)
            If r.offset(1, 0) = "" Then Exit Do
        Loop
        
        .Range("A13:A" & norec + 12) = ws_core.Range("A2:A" & norec + 1).Value
        .Range("C13:C" & norec + 12) = ws_core.Range("C2:C" & norec + 1).Value
        .Range("E13:E" & norec + 12) = ws_core.Range("F2:F" & norec + 1).Value
        .Range("F13:G" & norec + 12) = ws_core.Range("N2:O" & norec + 1).Value
        
        .Range("H13:H" & norec + 12) = ws_core.Range("AR2:AR" & norec + 1).Value
        .Range("I13:I" & norec + 12) = ws_core.Range("AU2:AU" & norec + 1).Value
        .Range("J13:J" & norec + 12) = ws_core.Range("X2:X" & norec + 1).Value
        .Range("K13:K" & norec + 12) = ws_core.Range("AA2:AA" & norec + 1).Value
        .Range("L13:L" & norec + 12) = ws_core.Range("AC2:AC" & norec + 1).Value
        '.Range("M13:M" & norec + 12) = ws_core.Range("BQ2:BQ" & norec + 1).Value
        '.Range("N13:N" & norec + 12) = ws_core.Range("BX2:BX" & norec + 1).Value
        '.Range("O13:O" & norec + 12) = ws_core.Range("CE2:CE" & norec + 1).Value
        '.Range("P13:P" & norec + 12) = ws_core.Range("CL2:CL" & norec + 1).Value
        .Range("Q13:Q" & norec + 12) = ws_core.Range("AX2:AX" & norec + 1).Value
        
        For i = 13 To 12 + norec
            fac5 = WorksheetFunction.VLookup(.Range("A" & i), ws_core.Range("A2:I" & norec + 1), 8, False) & WorksheetFunction.VLookup(.Range("A" & i), ws_core.Range("A2:I" & norec + 1), 9, False)
            .Range("D" & i) = WorksheetFunction.VLookup(fac5, fac_rng, 7, False)
            .Range("R" & i) = WorksheetFunction.VLookup(.Range("A" & i), ws_core.Range("A2:I" & norec + 1), 5, False)
            If .Range("Q" & i) = "FALSE" Then .Range("Q" & i) = ""
        Next i
        
        'tournament services
        If WorksheetFunction.CountIf(.Range("R:R"), "DT") > 0 Then
            For x = 13 To 12 + norec
                If .Range("R" & x) = "DT" Then
                    row_no = x 'worksheet row
                    dt_rid = .Range("A" & x) 'RID
                    dt_rid_row = WorksheetFunction.Match(dt_rid, ws_core.Range("A:A"), 0) 'source row of RID
                    no_srvs = WorksheetFunction.VLookup(dt_rid, ws_core.Range("A2:DO" & (norec + 1)), 119, False) 'number of tournament services
                    
                    'insert blank services rows
                    Set r = .Range("A" & row_no)
                    Do
                        .Range(r.offset(1, 0), r.offset(no_srvs, 0)).EntireRow.Insert
                        Set r = Cells(r.row + no_srvs + 1, 1)
                        If r.offset(1, 0) = "" Then Exit Do
                    Loop
                    
                    rw_start = x + 1
                    srv_cln = 13
                    ref_cm = 69
                    For jl = rw_start To (x + no_srvs)
                        'static data
                        .Range("A" & jl) = dt_rid
                        .Range(.Cells(x, 3), Cells(x, 7)).Copy Destination:=.Range("C" & jl)
                        
                        .Cells(jl, srv_cln) = WorksheetFunction.VLookup(dt_rid, ws_core.Range("A2:DO" & dt_rid_row), ref_cm, False)
    
                        .Range("R" & jl) = "DTS"
                        .Range("S" & jl) = ref_cm
                        
                        cntr = cntr + 1
                        If cntr = 4 Then
                            srv_cln = 13
                        Else
                            srv_cln = srv_cln + 1
                        End If
                        ref_cm = ref_cm + 7
                    Next jl
                    
                End If
            Next x
        End If
        
        CList(1) = "DT"
        CList(2) = "DTS"
        CList(3) = "DR"
        CList(4) = "FT"
        CList(5) = "FR"
        CList(6) = "CT"
        CList(7) = "CR"
        
        norec = WorksheetFunction.Count(.Range("C:C"))
        Application.AddCustomList ListArray:=CList
        .Range("A13:S" & norec + 12).Sort key1:=.Range("R13"), order1:=xlAscending, key2:=Range("F13"), order2:=xlAscending, key3:=Range("D13"), order3:=xlAscending, Header:=xlGuess, _
            OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
        For i = 1 To 8
            s_rpt = sReport(i)
            Sheets("Master").Copy After:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = s_rpt
                For y = (norec + 12) To 13 Step -1
                    If WorksheetFunction.CountIf(ActiveSheet.Range("H" & y & ":Q" & y), s_rpt) = 0 Then
                        .Rows(y).EntireRow.Delete
                    End If
                Next y
                llastrow = .Range("R" & Rows.Count).End(xlUp).row

                Set r_body = .Range("H13:Q" & llastrow)
                s_crew = s_rpt & "1"
                s_crew_name = WorksheetFunction.VLookup(s_crew, ws_corestaff.Range("A4:E18"), 3, False)
                
                .Range("M4") = s_crew_name
                .Range("M5") = Format(WorksheetFunction.VLookup(s_crew, ws_corestaff.Range("A4:E18"), 4, False), "h:mmA/P") & " - " & Format(WorksheetFunction.VLookup(s_crew, ws_corestaff.Range("A4:E18"), 5, False), "h:mmA/P")
                .Range("O4") = s_crew
                If s_rpt <> "CUL" Then 'bypass this section for CUL that doesn't have a second staff person
                    s_crew2 = s_rpt & "2"
                    s_crew_name2 = WorksheetFunction.VLookup(s_crew2, ws_corestaff.Range("A4:E18"), 3, False)
                    If s_crew_name2 = "Not Staffed" Then
                        .Range("P4:P5") = ""
                    Else
                        .Range("P4") = s_crew_name2
                        .Range("P5") = Format(WorksheetFunction.VLookup(s_crew2, ws_corestaff.Range("A4:E18"), 4, False), "h:mmA/P") & " - " & Format(WorksheetFunction.VLookup(s_crew2, ws_corestaff.Range("A4:E18"), 5, False), "h:mmA/P")
                    End If
                End If
                
                For Each c In Range("H13:Q" & llastrow)
                    If c.Value = s_rpt Then
                        c.Interior.ColorIndex = 2
                        c.font.ColorIndex = 2
                    Else
                        c.Interior.ColorIndex = 15
                        c.font.ColorIndex = 15
                    End If
                Next c
                
                SR = 13
                pristaff = s_crew_name
                
                '** tournament **
                If WorksheetFunction.CountIf(.Range("R:R"), "DTS") > 0 Then
                    For h = 13 To llastrow
                        If .Range("R" & h) = "DTS" Then
                            For Each d In .Range("M" & h & ":P" & h)
                                If d.Interior.ColorIndex = 2 Then
                                    ll = d.Value
                                    lcolm = d.Column
                                End If
                            Next d
                            tg_RID = .Range("A" & h)
                            l_clm = .Range("S" & h).Value - 7
                            r_clm = .Range("S" & h).Value + 7
                            src_RID_row = Application.WorksheetFunction.Match(tg_RID, ws_core.Range("A:A"), 0)
                            l_clm_val = ws_core.Cells(src_RID_row, l_clm)
                            r_clm_val = ws_core.Cells(src_RID_row, r_clm)
                            If lcolm > 13 Then
                                If l_clm_val <> ll Then
                                    .Cells(h, lcolm - 1) = l_clm_val
                                    .Cells(h, lcolm - 1).font.ColorIndex = 1
                                End If
                            End If
                            If lcolm < 16 Then
                                If r_clm_val <> ll Then
                                    .Cells(h, lcolm + 1) = r_clm_val
                                    .Cells(h, lcolm - 1).font.ColorIndex = 1
                                End If
                            End If
                         End If
                    Next h
                End If

                reveal_me ws_core, llastrow, r_body '[module41]
                
                '** DISPATCH **
                
                pristaff = Left(.Range("O4"), 3)
                For t = SR To llastrow
                    .Range("B" & t).font.size = 6
                    If .Range("H" & t) = pristaff Then 'groom time
                        .Range("B" & t) = Application.VLookup(.Range("A" & t), rcore, 43, False)
                    ElseIf .Range("I" & t) = pristaff Then
                        prp_type = Application.VLookup(.Range("A" & t), rcore, 30, False)
                        If prp_type = "" Then
                            'do nothing
                        ElseIf prp_type = "INI" Then
                            .Range("B" & t) = Application.VLookup(.Range("A" & t), rcore, 46, False)
                        Else
                            If prp_type = "REL" Then prp_type = "reline"
                            If prp_type = "CHG" Then prp_type = "change"
                            .Range("B" & t) = UCase(prp_type) & "  " & Application.VLookup(.Range("A" & t), rcore, 46, False)
                            .Range("B" & t).Characters(1, 6).font.Bold = True
                        End If
                     End If
                     If .Range("R" & t) = "DTS" Then
                        dts_div = Application.VLookup(.Range("A" & t), rcore, .Range("S" & t) - 4, False)
                        If dts_div = "REL" Then dts_div = "RELINE"
                        If dts_div = "CHG" Then dts_div = "CHANGE"
                        dts_lwr = Format(Application.VLookup(.Range("A" & t), rcore, .Range("S" & t) - 6, False), "h:mmA/P")
                        dts_upr = Format(Application.VLookup(.Range("A" & t), rcore, .Range("S" & t) - 5, False), "h:mmA/P")
                        .Range("B" & t) = dts_div & " " & dts_lwr & "-" & dts_upr
                        Range("B" & t).Characters(1, 6).font.Bold = True
                    End If
                 Next t '*** end of any single worksheet work
                
                 '** INSERT SEPARATOR ROWS
    
                Dim mcol As String

                cm = .Cells(Rows.Count, "R").End(xlUp).row
                mcol = Cells(cm, 18).Value
                For h = cm To 13 Step -1
                    If Cells(h, 18).Value <> mcol Then
                        mcol = Cells(h, 18).Value
                        Rows(h + 1).Insert
                        Rows(h + 1).Interior.ColorIndex = 2
                    End If
                Next h
            
                '** SORT **
                
                Dim lRowst As Long
                Dim lRowed As Long
                Dim vg As String
                Dim cntdr As Long
                Dim pp, bm As Long
                Dim po As Long
                Dim kl2 As String
                Dim oRangeSort As Range
                
                arr2 = Array("DT", "DTS", "DR", "FR", "FT", "CR", "CT")
                llastrow = .Range("R" & Rows.Count).End(xlUp).row
                Set rdata = .Range("R13:R" & llastrow)
    
                For po = 0 To UBound(arr2)
                    vg = arr2(po) 'active worksheet
    
                    cntdr = Application.CountIf(rdata, vg)
    
                    If cntdr > 0 Then 'there is no vg rows
            
                        On Error Resume Next
                        lRowst = Application.Match(vg, rdata, 0)
                        On Error GoTo 0
            
                        lRowst = lRowst + 12
                        lRowed = lRowst + cntdr - 1
                
                        For pp = lRowst To lRowed
                            If .Range("R" & pp) = "DTS" Then
                                kl2 = InStr(.Range("B" & pp).Value, "-") - 1
                                .Range("T" & pp).Value = TimeValue(Mid(.Range("B" & pp).Value, 8, InStr(.Range("B" & pp).Value, "-") - 1 - 7))
                            Else
                                bm = Len(.Range("B" & pp)) - 1
                                If bm > 0 Then
                                    If bm > 12 Then
                                        .Range("T" & pp).Value = TimeValue(Right(.Range("B" & pp).Value, bm - 8))
                                    Else
                                        .Range("T" & pp).Value = TimeValue(Right(.Range("B" & pp).Value, bm))
                                    End If
                                End If
                            End If
                        Next pp
                    
                        Set oRangeSort = .Range("A" & lRowst & ":T" & lRowed)
                        oRangeSort.Sort key1:=Range("T" & lRowst), order1:=xlAscending, key2:=Range("Q" & lRowst), order2:=xlDescending, Header:=xlNo, _
                            OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
                            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
                    Else
                        'MsgBox vg & "No"
                    End If

                Next po
            
                '** MERGE DISPATCH **

                Dim n As Long
                Const mergeCol As String = "B"
                Const frData As Long = 13
                
                arr2 = Array("DT", "DTS", "DR", "FR", "FT", "CR", "CT")
                llastrow = .Range("R" & Rows.Count).End(xlUp).row
                Set rdata = .Range("R13:R" & llastrow)
    
                For po = 0 To UBound(arr2)
                    vg = arr2(po) 'active worksheet
    
                    cntdr = Application.CountIf(rdata, vg)
    
                    If cntdr > 0 Then 'there is no vg rows
            
                        On Error Resume Next
                        lRowst = Application.Match(vg, rdata, 0)
                        On Error GoTo 0
            
                        lRowst = lRowst + 12
                        lRowed = lRowst + cntdr - 1
                        
                        'Set y = .Range("B" & lRowst, "B" & lRowed)
                        Application.DisplayAlerts = False
                        Application.ScreenUpdating = False
                        For y = lRowed To lRowst Step -1
                            With Cells(y, mergeCol)
                                If .Value = .offset(-1).Value And .Value <> "" Then
                                    With .offset(-1).Resize(2)
                                        .Merge
                                        .WrapText = True
                                        .VerticalAlignment = xlCenter
                                        .HorizontalAlignment = xlCenter
                                    End With
                                End If
                             End With
                        Next y

                         Application.DisplayAlerts = True
                        Application.ScreenUpdating = True
                    End If
                
                Next po
                With .Range("A13:P" & llastrow)
                    .EntireRow.AutoFit
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
                With .Range("D13:E" & llastrow)
                    .HorizontalAlignment = xlLeft
                End With
            
            End With
        Next i
        
        fac_services.Show
        
        With ws_wkmaster
            For u = 2 To 21
                s_sdd = Left(Worksheets("Services").Range("E" & u), 3)
                If s_sdd = "SEC" Then
                    'do nothing
                Else
                    Set trgt_wksh = Worksheets(s_sdd)
                    With trgt_wksh
                        .Activate
                        lrow = Application.WorksheetFunction.Match("mark", .Range("A1:A200"), 0)
                        .Range("A" & lrow).EntireRow.Insert
                        '.Range("A" & lrow + 1) = "mark"
                        .Range("A" & lrow) = ""
                        .Range("C" & lrow) = Worksheets("Services").Range("F" & u)
                        .Range("E" & lrow) = Worksheets("Services").Range("G" & u)
                        With .Range("B" & lrow)
                            .Value = Worksheets("Services").Range("D" & u)
                            .font.size = 6
                            .VerticalAlignment = xlCenter
                            .HorizontalAlignment = xlCenter
                        End With
                        .Range("T" & lrow) = Worksheets("Services").Range("C" & u)
                    End With
                End If
                'add to master
                lrow = Application.WorksheetFunction.Match("mark", .Range("A1:A200"), 0)
                .Range("A" & lrow).EntireRow.Insert
                .Range("A" & lrow) = ""
                .Range("C" & lrow) = Worksheets("Services").Range("F" & u)
                .Range("E" & lrow) = Worksheets("Services").Range("G" & u)
                With .Range("B" & lrow)
                    .Value = Worksheets("Services").Range("D" & u)
                    .font.size = 6
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                End With
                .Range("K" & lrow) = s_sdd
                .Range("T" & lrow) = Worksheets("Services").Range("C" & u)

            Next u
        End With
            
        'tournament maintenance services
        'under development
        With ws_core
            Dim l_row_tf
            Dim wpe_twr_max As Double, af As Double, c1 As String
            
            If .AutoFilterMode Then .AutoFilterMode = False
            If WorksheetFunction.CountIf(.Range("E:E"), "*T") > 0 Then
                MsgBox "Feature unavailble." & Chr(13) & "Tournament maintenance services must be manually" & Chr(13) & "entered on the appropriate worksheets.", vbCritical, "TOURNAMENT MAINTENANCE SERVICES"
                'If WorksheetFunction.CountIfs(.Range("E:E"), "=*T", .Range("H:H"), "=Hillside Park") > 0 Then 'HP restroom maintenance required
                'End If
                'If WorksheetFunction.CountIfs(.Range("E:E"), "=*T", .Range("H:H" & l_row_tf), "=RIM Park Outdoor", .Range("EF:EF"), "=RIM_GL") > 0 Then 'GL restroom maintenance required
                'End If
                'If WorksheetFunction.CountIfs(.Range("E:E"), "=*T", .Range("H:H"), "=Westmount Sports Park") > 0 Then 'WSP restroom maintenance required
                'End If
                'If WorksheetFunction.CountIfs(.Range("E:E"), "=*T", .Range("H:H"), "=Waterloo Park", .Range("EF:EF"), "=WP-E") > 0 Then 'WP restroom maintenance required
                '    With .Range("A1:EG1")
                '        .AutoFilter
                '        .AutoFilter Field:=5, Criteria1:="=*T"
                '        .AutoFilter Field:=136, Criteria1:="WP-E"
                '    End With
                '    wpe_twr_max = WorksheetFunction.Subtotal(105, .Range("O:O"))
                '    If wpe_twr_max > 0.708333 Then
                '        af = 136
                '        c1 = "WP-E"
                '        If .AutoFilterMode Then .AutoFilterMode = False
                '        fac_mtnce_services ws_core, ws_th, wpe_twr_max, af, c1 '[module 44]
                '    End If
                'End If
                'If WorksheetFunction.CountIfs(.Range("E:E"), "=*T", .Range("H:H"), "=Waterloo Park", .Range("EF:EF"), "=WP-W") > 0 Then 'WP restroom maintenance required
                'End If
            End If
        End With
            
        With wksh_book
        
            Dim va As Variant
            arr4 = Array("Master", "CUE", "CUL", "HPE", "HPL", "RPE", "RPL", "WPE", "WPL")
            
            For po = 0 To UBound(arr4)
                Set va = Worksheets(arr4(po)) 'active worksheet
                'Const mergeCol As String = "B"
                With va
                    base_row = WorksheetFunction.Match("Facility Maintenance Activities", .Range("A:A"), 0) + 4
                    lrow = WorksheetFunction.Match("mark", .Range("A:A"), 0) - 1
                    If lrow > base_row Then 'ok to sort
                        Set oRangeSort = .Range("A" & base_row & ":T" & lrow)
                        oRangeSort.Sort key1:=.Range("T" & base_row), order1:=xlAscending, key2:=.Range("Q" & base_row), order2:=xlDescending, Header:=xlNo, _
                            MatchCase:=False, _
                            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
                        Application.DisplayAlerts = False
                        For y = lrow To base_row Step -1
                            With Cells(y, mergeCol)
                                If .Value = .offset(-1).Value And .Value <> "" Then
                                    With .offset(-1).Resize(2)
                                        .Merge
                                        .WrapText = True
                                        .VerticalAlignment = xlCenter
                                        .HorizontalAlignment = xlCenter
                                    End With
                                End If
                             End With
                        Next y
                        Application.DisplayAlerts = True
                    End If

                End With
            Next po
                        
            With ws_core
                If .AutoFilterMode Then .AutoFilterMode = False
                llastrow = .Range("A" & Rows.Count).End(xlUp).row
                
            'Signature eligibility
                For i = 2 To llastrow
                    If .Range("W" & i) = "NR" Or .Range("W" & i) = "NA" Then
                        RID = .Range("A" & i)
                        ka2 = .Range("X" & i)
                        Set ka = wksh_book.Worksheets(ka2)
                        With ka
                            .Activate
                            lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                            With .Range("J" & lrow)
                                .Value = ws_core.Range("W" & i)
                                .font.size = 8
                                .font.Color = vbBlack
                                .VerticalAlignment = xlCenter
                                .HorizontalAlignment = xlCenter
                            End With
                        End With
                        With wksh_book.Worksheets("Master")
                            .Activate
                            lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                            With .Range("J" & lrow)
                                .Value = ws_core.Range("W" & i)
                                .font.size = 8
                                .font.Color = vbBlack
                                .VerticalAlignment = xlCenter
                                .HorizontalAlignment = xlCenter
                            End With
                        End With
                    End If
                    
                'Diamonds only
                    If Left(.Range("E" & i), 1) = "D" Then
                    
                    'groom eligibility
                        If .Range("AQ" & i) = "NA" Or .Range("AQ" & i) = "NR" Then
                            RID = .Range("A" & i)
                            ka2 = .Range("AU" & i)
                            Set ka = wksh_book.Worksheets(ka2)
                            With ka
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("H" & lrow)
                                    .Value = ws_core.Range("AQ" & i)
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                            With wksh_book.Worksheets("Master")
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("H" & lrow)
                                    .Value = ws_core.Range("AQ" & i)
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                        End If
                        
                    'groom dates
                        If .Range("AP" & i) <> ws_vh.Range("B2") Then
                            RID = .Range("A" & i)
                            ka2 = .Range("AU" & i)
                            Set ka = wksh_book.Worksheets(ka2)
                            With ka
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("H" & lrow)
                                    .Value = UCase(Format(ws_core.Range("AP" & i), "DDD") & " " & Right(ws_core.Range("AQ" & i), 2))
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                            With wksh_book.Worksheets("Master")
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("H" & lrow)
                                    .Value = UCase(Format(ws_core.Range("AP" & i), "DDD") & " " & Right(ws_core.Range("AQ" & i), 2))
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                        End If
                        
                    'prep eligibility
                        If .Range("AT" & i) = "NA" Or .Range("AT" & i) = "NR" Then
                            RID = .Range("A" & i)
                            ka2 = .Range("X" & i)
                            Set ka = wksh_book.Worksheets(ka2)
                            With ka
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("I" & lrow)
                                    .Value = ws_core.Range("AQ" & i)
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                            With wksh_book.Worksheets("Master")
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("I" & lrow)
                                    .Value = ws_core.Range("AQ" & i)
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                        End If
                        
                    'prep dates
                        'If .Range("AS" & i) <> ws_vh.Range("B2") Then
                        '    RID = .Range("A" & i)
                        '    Set ka = wksh_book.Worksheets(.Range("AP" & i))
                        '    With ka
                        '        lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                        '        With .Range("I" & lrow)
                         '           .Value = UCase(Format(ws_core.Range("AS" & i), "DDD") & " " & Right(ws_core.Range("AT" & i), 2))
                        '            .font.size = 8
                        '            .font.Color = vbBlack
                        '            .VerticalAlignment = xlCenter
                        '            .HorizontalAlignment = xlCenter
                        '        End With
                        '    End With
                        '    With wksh_book.Worksheets("Master")
                        '        lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                        '        With .Range("I" & lrow)
                        '            .Value = UCase(Format(ws_core.Range("AS" & i), "DDD") & " " & Right(ws_core.Range("AT" & i), 2))
                        '            .font.size = 8
                        '            .font.Color = vbBlack
                        '            .VerticalAlignment = xlCenter
                        '            .HorizontalAlignment = xlCenter
                        '        End With
                        '    End With
                        'End If
                        
                    'close eligibility
                        If .Range("AW" & i) = "NA" Or .Range("AW" & i) = "NR" Then
                            RID = .Range("A" & i)
                            ka2 = .Range("X" & i)
                            Set ka = wksh_book.Worksheets(ka2)
                            With ka
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("Q" & lrow)
                                    .Value = ws_core.Range("AW" & i)
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                            With wksh_book.Worksheets("Master")
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("Q" & lrow)
                                    .Value = ws_core.Range("AW" & i)
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                        End If
                        
                    'close dates
                        If .Range("AV" & i) <> ws_vh.Range("B2") Then
                            RID = .Range("A" & i)
                            ka2 = .Range("X" & i)
                            Set ka = wksh_book.Worksheets(ka2)
                            With ka
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("Q" & lrow)
                                    .Value = UCase(Format(ws_core.Range("AV" & i), "DDD") & " " & Right(ws_core.Range("AW" & i), 2))
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                            With wksh_book.Worksheets("Master")
                                .Activate
                                lrow = WorksheetFunction.Match(RID, .Range("A:A"), 0)
                                With .Range("Q" & lrow)
                                    .Value = UCase(Format(ws_core.Range("AV" & i), "DDD") & " " & Right(ws_core.Range("AW" & i), 2))
                                    .font.size = 8
                                    .font.Color = vbBlack
                                    .VerticalAlignment = xlCenter
                                    .HorizontalAlignment = xlCenter
                                End With
                            End With
                        End If
                    End If
                Next i
            End With
        
        With wksh_book
        
            arr4 = Array("Master", "CUE", "CUL", "HPE", "HPL", "RPE", "RPL", "WPE", "WPL")
            
            For po = 0 To UBound(arr4)
                Set va = Worksheets(arr4(po)) 'active worksheet
                With va
                    If va.Name <> "Master" Then
                        If .Range("P4") = "Max Time" Then
                            .Range("P4:P5") = ""
                        End If
                    End If
                    fma_row = WorksheetFunction.Match("Facility Maintenance Activities", Range("A:A"), 0)
                    llastrow = fma_row - 3
                    For i = 8 To 17                     'columns
                        For j = 13 To llastrow          'rows
                            If .Cells(j, i).Value <> "" Then
                                If .Cells(j, i).Value = "FALSE" Then
                                    .Cells(j, i).Value = ""
                                Else
                                    On Error Resume Next
                                    .Cells(j, i) = WorksheetFunction.VLookup((.Cells(j, i) & "1"), ws_corestaff.Range("A4:C17"), 3, False)
                                    On Error GoTo 0
                                End If
                            End If
                        Next j
                    Next i
                    If va.Name = "Master" Then
                        base_row = WorksheetFunction.Match("Facility Maintenance Activities", .Range("A:A"), 0) + 4
                        lrow = WorksheetFunction.Match("mark", .Range("A:A"), 0) - 1
                        For i = base_row To lrow
                            On Error Resume Next
                            .Range("K" & i) = WorksheetFunction.VLookup((.Range("K" & i) & "1"), ws_corestaff.Range("A4:C17"), 3, False)
                            On Error GoTo 0
                        Next i
                    End If
                
                End With
            Next po
        
        End With
  
    'fill pages (default height 643.5 pts)
        
        With wksh_book
            Dim dph As Double, cph As Double, markrow As Double, llrow As Double, diff As Double, rta As Double, a_pda As Double, a_fma As Double, fmarow As Double
            Dim q As Range, lrow_pda As Double, lrow_fma As Double, ac As Range, add_apda As Double, add_afma As Double
            Dim ptrh As Double
                                    
            dph = 579.75
            
            arr4 = Array("Master", "CUE", "CUL", "HPE", "HPL", "RPE", "RPL", "WPE", "WPL")
            
            For po = 0 To UBound(arr4)
                Set va = Worksheets(arr4(po)) 'active worksheet
                ptrh = 0
                With va
                    .Activate
                    markrow = Application.WorksheetFunction.Match("mark", .Range("A1:A200"), 0)
                    llrow = markrow + 4
                    For Each q In .Range("A1:A" & llrow)
                        ptrh = ptrh + q.Height
                    Next q
                    diff = dph - ptrh
                    rta = WorksheetFunction.RoundDown((diff / 12.75), 0)
                    MsgBox "Default page height:   579.75 pts" & Chr(13) & "Current page height:   " & ptrh & " pts" & Chr(13) & "Difference:   " & diff & " pts" & Chr(13) & "Rows to add:   " & rta
                    If rta > 0 Then
                        a_pda = WorksheetFunction.RoundDown((0.6 * rta), 0)
                        a_fma = rta - a_pda
                        fmarow = Application.WorksheetFunction.Match("Facility Maintenance Activities", .Range("A1:A200"), 0)
                        lrow_pda = fmarow - 3
                        Set ac = ActiveSheet.Cells(lrow_pda, 1)
                        For add_apda = 1 To a_pda
                            ac.offset(add_apda).EntireRow.Insert
                        Next add_apda
                        .Range("H" & lrow_pda + 1 & ":Q" & lrow_pda + a_pda).Interior.ColorIndex = RGB(0, 0, 0)
                        fmarow = Application.WorksheetFunction.Match("mark", .Range("A1:A200"), 0)
                        lrow_fma = fmarow - 1
                        Set ac = ActiveSheet.Cells(lrow_fma, 1)
                        For add_afma = 1 To a_fma
                            ac.offset(add_afma).EntireRow.Insert
                        Next add_afma
                    End If
                    On Error Resume Next
                    .Range("A" & lrow_fma + a_fma) = ""
                    On Error GoTo 0
                End With
                
            Next po
        
        End With
        Workbooks(ws_name).Save
        ui1 = MsgBox("Worksheets for " & Format(ws_vh.Range("B2"), "ddd, mmmm dd") & " have been created and saved." & Chr(13) & "Do you wish to view them?", vbQuestion + vbYesNo, "WORKSHEET SUCCESS")
        If ui1 = vbYes Then
            MsgBox "Goodbye"
            End
        End If
    End With
End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    wksh_book.Windows(1).Visible = True
End Sub

 

[Macropod]

The worksheet.copy method apparently won't work if the destination workbook window isn't visible, so you might have to leave the 'wksh_book.Windows(1).Visible = False' until after you've done the Services & Master sheet replications.

 

[Ark68]

Thank you Paul.
That is unfortunate, but it is what it is.

I noted that you closed my other post. I respect that, however, understand that although the question was related to the same code, the original problem in that post was unique. It evolved into a similar problem as this, so I feel it was unfair to say I duplicated the post.