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