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 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:

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


    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

                If CurrentSheet.Cells(7, c).Value + "Total" Then
                    c = c + 1
                    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"
                        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

            EndLoop1 = True

        End If

    a = a + 1

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

End Sub
  • 1
    \$\begingroup\$ Welcome to CR! Please take a moment to edit your post to tell reviewers about your code, about its purpose; what these loops do and what's in all these cells you're interacting with - the more you give to reviewers, the more reviewers give to you! Know that Rubberduck inspections would raise a number of inspection results that reviewers will definitely point out - e.g. Dim a, b As Long declares b as a Long, and leaves a as an implicit Variant. Disclaimer: I contribute to the Rubberduck open-source project. \$\endgroup\$ – Mathieu Guindon Apr 4 '19 at 0:55
  • \$\begingroup\$ Thanks Mathieu, I have updated the description with the objectives of the code. Does that make sense or should I go into further detail? \$\endgroup\$ – Josh T Apr 4 '19 at 1:11
  • \$\begingroup\$ Thanks! Feel free to add as much information as you want - up to 60K characters! =) \$\endgroup\$ – Mathieu Guindon Apr 4 '19 at 1:23
  • 1
    \$\begingroup\$ Can you show an example of your standard roster sheet and the "current" sheet with data? \$\endgroup\$ – PeterT Apr 5 '19 at 12:30
  • \$\begingroup\$ Hi Peter, I have updated my description with some screenshots of the standard roster sheet and current sheet. \$\endgroup\$ – Josh T Apr 9 '19 at 1:58

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.