Ttykuu

The below code works however it takes several minutes to run. Is there a way to optimise performance so that it can be completed in a shorter amount of time?

My code is designed to look at the "Standard Roster" worksheet and use information in that worksheet of start and end times of a 14 day roster and compare that to the current worksheet and put the appropriate label into the 30 minute blocks over the whole month for the appropriate staff member.

This is Current Sheet and it continues by 30 minute blocks until the end of the month.

This is the "Standard Roster" Sheet. It has a total of 150 names:

Code:

 Sub FillStandardHours()
'
' FillStandardHours Macro
'

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


Dim CurrentSheet As Worksheet
Dim StandRosSheet As Worksheet
Dim CurrentSheetLastColumn As Integer
Dim CurrentSheetLastRow As Integer
Dim StandRosLastColumn As Integer
Dim StandRosLastRow As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim DayNum As Integer
Dim EndLoop1 As Boolean
Dim EndLoop2 As Boolean
Dim StaffActualTime As Date
Dim RosterActualStartTime As Date
Dim RosterActualEndTime As Date


Set CurrentSheet = Sheets(ActiveSheet.Name)
CurrentSheetLastColumn = CurrentSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
CurrentSheetLastRow = CurrentSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

Set StandRosSheet = Sheets("Standard Roster")
StandRosLastColumn = StandRosSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
StandRosLastRow = StandRosSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

CurrentSheet.DisplayPageBreaks = False
StandRosSheet.DisplayPageBreaks = False

a = 8

Do Until a = CurrentSheetLastRow + 1 'Go through every name on CurrentSheet

 b = 8
 EndLoop1 = False

 Do Until b = StandRosLastRow + 1 Or EndLoop1 = True 'For every name on CurrentSheet, go through every name on Standard Roster
 If StandRosSheet.Cells(b, 3).Value = CurrentSheet.Cells(a, 3).Value Then

 c = 7
 Do Until c = CurrentSheetLastColumn + 1

 d = 8
 DayNum = CurrentSheet.Cells(6, c).Value
 Do Until StandRosSheet.Cells(7, d).Value = DayNum Or d = 22
 If StandRosSheet.Cells(7, d).Value <> DayNum Then
 d = d + 1
 End If

 If d = 22 Then
 MsgBox "Error: " & DayNum & " in " & CurrentSheet.Name & " worksheet does not correspond to the Standard Roster", vbOKOnly, "Error Filling " & CurrentSheet.Name & " with Standard Roster"
 Exit Sub
 End If
 Loop

 If CurrentSheet.Cells(7, c).Value + "Total" Then
 c = c + 1
 Else:
 StaffActualTime = TimeValue(CurrentSheet.Cells(7, c).Text)

 If StandRosSheet.Cells(b, d).Offset(1, 0).Text = vbNullString Or StandRosSheet.Cells(b, d).Offset(2, 0).Text = vbNullString Then
 CurrentSheet.Cells(a, c).Value = "NR"
 Else:
 RosterActualStartTime = Format((Round(StandRosSheet.Cells(b, d).Offset(1, 0).Value * 48, 0) / 48), "hh:mm AM/PM")
 RosterActualEndTime = Format((Round(StandRosSheet.Cells(b, d).Offset(2, 0).Value * 48, 0) / 48), "hh:mm AM/PM")

 If StaffActualTime < RosterActualStartTime Or StaffActualTime > RosterActualEndTime Then
 CurrentSheet.Cells(a, c).Value = "NR"
 ElseIf StandRosSheet.Cells(b, d).Offset(4, 0).Value = "WFH" Then
 CurrentSheet.Cells(a, c).Value = "WFH"
 Else: CurrentSheet.Cells(a, c).Value = "STD"
 End If
 End If

 c = c + 1

 End If
 Loop

 EndLoop1 = True

 End If
 Loop

 a = a + 1
Loop

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

'
End Sub