# Comparing times of two worksheets

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

• 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. – Mathieu Guindon Apr 4 '19 at 0:55
• Thanks Mathieu, I have updated the description with the objectives of the code. Does that make sense or should I go into further detail? – Josh T Apr 4 '19 at 1:11
• Thanks! Feel free to add as much information as you want - up to 60K characters! =) – Mathieu Guindon Apr 4 '19 at 1:23
• Can you show an example of your standard roster sheet and the "current" sheet with data? – PeterT Apr 5 '19 at 12:30
• Hi Peter, I have updated my description with some screenshots of the standard roster sheet and current sheet. – Josh T Apr 9 '19 at 1:58