Gfrktyl

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