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?

All suggestions and improvements will be highly appreciated.

Code:

Sub FillStandardHours()
'
' FillStandardHours Macro
'

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


Dim CurrentSheet, StandRosSheet As Worksheet
Dim CurrentSheetLastColumn, CurrentSheetLastRow, StandRosLastColumn, StandRosLastRow As Integer
Dim a, b, c, d, DayNum As Integer
Dim EndLoop1, EndLoop2 As Boolean


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 = 9

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 IsEmpty(CurrentSheet.Cells(8, c)) Then
 c = c + 1
 Else:

 If CurrentSheet.Cells(8, c).Value < StandRosSheet.Cells(b, d).Offset(1, 0).Value Or CurrentSheet.Cells(8, c).Value > StandRosSheet.Cells(b, d).Offset(2, 0).Value Or (IsEmpty(StandRosSheet.Cells(b, d).Offset(1, 0).Value) And IsEmpty(StandRosSheet.Cells(b, d).Offset(2, 0).Value)) 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

 c = c + 1

 End If
 Loop

 EndLoop1 = True

 Else: b = b + 1
 End If
 Loop

 a = a + 1
Loop

CurrentSheet.DisplayPageBreaks = True
StandRosSheet.DisplayPageBreaks = True

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

'
End Sub