Glasgow Report Template

This code is the standard for the Glasgow Reports. This is much quicker than the V1 Reports I created when I started at Glasgow.

Sub SLA_Extract '======================================================================       '= Brian McCafferty - May 2010 - Adapted from Original Code by:       = '= Oli Moffatt - June 2009                                           = '= Queries CR Log and retrieves relevant details for all             = '= CRs where the SLA is at Risk or has already breached              = '======================================================================       Dim Source As Worksheet Dim sht As Worksheet Dim ws As Worksheet Dim wb As Workbook Dim output As Workbook Dim x As Long Dim y As Long Dim count As Long Dim Fnd As Boolean Dim iRow As Long Dim CProj As Long Dim HeaderSuffix As String Dim WantRep As Boolean welcomebox = MsgBox("This tool will allow you to build the SLA Report Extract from the PMO Log" & vbCrLf & vbCrLf & _                       "Please ensure you have updated, saved and CLOSED the Log before starting" & vbCrLf & vbCrLf & _                        "WARNING.  If you do not close & save the log you WILL lose your changes!" & vbCrLf & vbCrLf & _                        "Have you saved and closed the log and are ready to continue?", vbQuestion + vbYesNo, "Capita PMO Extract Builder") If welcomebox = vbYes Then 'Turn off alerts/error messages for the user Application.DisplayAlerts = False update_status "Importing from Log ..." 'Open The Log Read Only No to Updates Workbooks.Open Filename:=Range("Menu!M5").Value, UpdateLinks:=0, ReadOnly:=True 'Select top cell Range("B19").Activate Set ws = ActiveWorkbook.Sheets("IA") Set wb = ActiveWorkbook Workbooks.Add 'create new workbook for output Set output = ActiveWorkbook ReportWinName = ActiveWindow.Caption Sheets("Sheet1").Name = "SLA Report" Set sht = ActiveSheet With ws           iRow = (ws.Cells(Rows.count, 2) _            .End(xlUp).Offset(1, 0).Row) 'count rows 'HEADINGS 'always write to first row as first report will always come at top sht.Cells(1, 1) = "CR SLA Report" ' This is the Report Title. sht.Cells(2, 1) = "CR Number" sht.Cells(2, 2) = "Child CR Number" sht.Cells(2, 3) = "Request Type" sht.Cells(2, 4) = "Title" sht.Cells(2, 5) = "Overall Status" sht.Cells(2, 6) = "Date Received" sht.Cells(2, 7) = "Priority" sht.Cells(2, 8) = "Capita Internal Target" sht.Cells(2, 9) = "Client SLA" sht.Cells(2, 10) = "Day 5 Date" sht.Cells(2, 11) = "Overall CR RAG Status" sht.Cells(2, 12) = "Comments" sht.Cells(2, 13) = "Area Leading IA" sht.Cells(2, 14) = "Capita Leads Area Manager" sht.Cells(2, 15) = "IA Lead" sht.Cells(2, 16) = "IA Owner (IT)" sht.Cells(2, 17) = "IA Owner (CD)" sht.Cells(2, 18) = "Time to Estimate?" sht.Cells(2, 19) = "IT Involved?" sht.Cells(2, 20) = "Change Delivery Involved?" sht.Cells(2, 21) = "Capita Ops Involved?" sht.Cells(2, 22) = "Likely Value" sht.Cells(2, 23) = "Op Risk/Impact Transformation/Impact BAU Costs?" sht.Cells(2, 24) = "Requested Pre-PAB Date" sht.Cells(2, 25) = "Requested PAB Date" sht.Cells(2, 26) = "Issues identified work order, if it will impact ability to meet SLA?" sht.Cells(2, 27) = "Did we contact the client by Day 2?" 'Set up date range to check SLAs Against Current_Dte = CDate(Format(Now, "DD/MM/YY")) 'Activate the Extract Builter & Extract tab Windows("PMO Extract Builder.xls").Activate Range("Working!A1:A3").Clear Range("Working!A1").Value = Current_Dte Range("Working!A2").Formula = "=ADDWORKINGDAYS(A1,2)" Range("Working!A3").Formula = "=ADDWORKINGDAYS(A1,4)" ROM_Ext_Dte = Range("Working!A2").Value OTH_Ext_Dte = Range("Working!A3").Value 'Activate the Report Window Windows(ReportWinName).Activate 'DATA RETRIEVAL x = 3 'start writing data on row 3 y = 20 'start reading data from row 20 as all the stuff above is just guff! count = 0 'counter for loop CProj = 0 'counter for current report matched data Do Until count = (iRow - 20) 'loop through all CR entries, minus 20 from iRow as CRs start at row 20 If .Range("B" & y).Value > "" Then 'check that WO Ref exists WantRep = False ' Want this record on the report? Set to False/No at Start 'CRITERIA CHECKS - Check if status is IA and if dates are of intrest to us. 'Do the filtering/checking of the log If .Range("J" & y).Value <> "IA" Then 'We only want Status of IA and status is stored in col J so skip anything else! GoTo EstSentCli 'Go to the skip point below and move onto the next CR. End If           'First scenario for work orders to show on this report If .Range("G" & y).Value = "ROM" Then 'Check if this is a ROM, if so it only have a 2 day before SLA Highlight rule. If .Range("Q" & y).Value <= ROM_Ext_Dte Then WantRep = True Else GoTo EstSentCli 'Go to the skip point below and move onto the next CR. End If           Else ' Its not a ROM so use 4 day before highlight rule If .Range("Q" & y).Value <= OTH_Ext_Dte Then WantRep = True Else GoTo EstSentCli 'Go to the skip point below and move onto the next CR. End If           End If            If WantRep = True Then 'if CR matches criteria then pull the data from the log 'Pull Date from Log to Report. sht.Cells(x, 1) = .Range("B" & y).Value ' sht.Cells(x, 2) = .Range("C" & y).Value ' sht.Cells(x, 3) = .Range("G" & y).Value ' sht.Cells(x, 4) = .Range("H" & y).Value ' sht.Cells(x, 5) = .Range("J" & y).Value ' sht.Cells(x, 6) = .Range("M" & y).Value ' sht.Cells(x, 7) = .Range("N" & y).Value ' sht.Cells(x, 8) = .Range("P" & y).Value ' sht.Cells(x, 9) = .Range("Q" & y).Value ' sht.Cells(x, 10) = .Range("R" & y).Value ' sht.Cells(x, 11) = .Range("U" & y).Value ' sht.Cells(x, 12) = .Range("AB" & y).Value ' sht.Cells(x, 13) = .Range("AC" & y).Value ' sht.Cells(x, 14) = .Range("AD" & y).Value ' sht.Cells(x, 15) = .Range("AE" & y).Value ' sht.Cells(x, 16) = .Range("AF" & y).Value ' sht.Cells(x, 17) = .Range("AG" & y).Value ' sht.Cells(x, 18) = .Range("BC" & y).Value ' sht.Cells(x, 19) = .Range("BD" & y).Value ' sht.Cells(x, 20) = .Range("BE" & y).Value ' sht.Cells(x, 21) = .Range("BF" & y).Value ' sht.Cells(x, 22) = .Range("BG" & y).Value ' sht.Cells(x, 23) = .Range("BH" & y).Value ' sht.Cells(x, 24) = .Range("BI" & y).Value ' sht.Cells(x, 25) = .Range("BJ" & y).Value ' sht.Cells(x, 26) = .Range("BK" & y).Value ' sht.Cells(x, 27) = .Range("BL" & y).Value ' x = x + 1 'only increment x when valid entry found CProj = CProj + 1 End If           End If EstSentCli:             'jump to point for omitting WOs where estimate has been sent to client count = count + 1 y = y + 1 'increment y to read from next row on source data Loop End With 'FORMAT OUTPUT Range("A2:AA" & x - 1).Select 'borders With Selection.Borders(xlEdgeLeft) .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .Weight = xlThin End With Range("A1:AA1").Select 'format title with background With Selection .Interior.ColorIndex = 9 .Font.ColorIndex = 2 End With Range("A1:AA2").Font.Bold = True 'make headers bold Columns("B:AA").EntireColumn.AutoFit 'autofit columns Columns("D:AA").HorizontalAlignment = xlCenter Columns("A:A").ColumnWidth = 20 Range("A3:AA1000").Select Selection.RowHeight = 30 Range("A1").Select update_status "Ready" Workbooks("Royal London Master CR Log.xls").Close SaveChanges:=False End If End Sub Code Snippits