# Comparing dates from sheets

I am looking to increase the speed of this Excel VBA Nested Loop. The loop compares dates from one sheet to a secondary sheet. If they match, I change the border around the cell to highlight it. It currently works fine, but takes about 30 seconds to process per sub. Is there a way to implement an array or other tactic to speed it up?

Sub Single()

Dim DateRng As Range, DateCell As Range, DateRngPay As Range
Dim cellA As Range
Dim cellB As Range
Dim myColor As Variant

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")
myColor = Array("38")

If ActiveWorkbook.Worksheets("Info").Range("B67") = 1 Then
With DateRng
.Interior.ColorIndex = xlColorIndexNone
.Borders.ColorIndex = 1
.Borders.Weight = xlHairline
For Each cellA In DateRng
For Each cellB In DateRngPay
If cellB.Value > "" And cellA.Value > "" And cellB.Value = cellA.Value Then
With cellA.Borders
.ColorIndex = myColor
.Weight = xlMedium
End With
Exit For
End If
Next cellB
Next cellA
End With
End If
End Sub

• The first tip is to stop updating the screen while it runs: Application.ScreenUpdating = False and when you're done, turn it True again, It will give you some seconds of runtime, but will make Excel seem non-respondent – fernando.reyes Sep 9 '16 at 21:00
• Thanks Fernando... I just tried it out and there was no improvement. I have tried it in the past also with no luck either. I think the slow down is each cellA (300+) references each cellB (60+) which is 18,000+ times it has to check if the conditions are met – jb3700 Sep 9 '16 at 21:12
• Then you need to stop reading them and updating so many times, just something out of thin air: - vectorA[] = readCellsValues; vectorB[] = readsCellsValues; compareThemAll and save results on another vectorC[]; write down result after comparisons. – fernando.reyes Sep 9 '16 at 21:21
• Do I understand correctly that the problem statement could be worded as "if any cell from a specific range in sheet 'SS' has a value that exists anywhere in sheet 'PS' between C2 and C67, we need to format that cell"? – Mathieu Guindon Sep 9 '16 at 21:26
• That's correct Mat... We need to format the SS cell – jb3700 Sep 9 '16 at 21:28

Normally I'd go on and ramble about how your procedure's name should start with a verb, how the casing of your local variables isn't consistently camelCase, how the procedure is implicitly Public, how the indentation is broken and therefore confusing here:

With DateRng
.Interior.ColorIndex = xlColorIndexNone
.Borders.ColorIndex = 1
.Borders.Weight = xlHairline
For Each cellA In DateRng
For Each cellB In DateRngPay
If cellB.Value > "" And cellA.Value > "" And cellB.Value = cellA.Value Then
With cellA.Borders
.ColorIndex = myColor
.Weight = xlMedium
End With
Exit For
End If
Next cellB
Next cellA
End With


Compare to:

With DateRng
.Interior.ColorIndex = xlColorIndexNone
.Borders.ColorIndex = 1
.Borders.Weight = xlHairline
For Each cellA In DateRng
For Each cellB In DateRngPay
If cellB.Value > "" And cellA.Value > "" And cellB.Value = cellA.Value Then
With cellA.Borders
.ColorIndex = myColor
.Weight = xlMedium
End With
Exit For
End If
Next cellB
Next cellA
End With


...I'd also so mention that I find cellB.Value > "" a little weird when everyone else would have written cellB.Value <> "" or perhaps cellB.Value <> vbNullString.

I might even have wrecked my brains around trying to find a way to remove the need for a nested loop at all.

All of that would have been useful advice... but there's an even better one.

Unless you have a VERY specific and cast-in-stone requirement for the border width, there's no need for any VBA code to do this.

First, name the range on SS!$C$2:$C$67, say MyValues - here I've populated the data with values 1-66, but anything will do:

On the PS sheet, select cell PS!$B$11 and create a conditional format for it, using this formula:

=AND(Info!$B$67=1,NOT(ISNA(MATCH(B11,MyValues,0))))


Decide how you want the conditional format to look like, and then change the applies to range to the cells you're interested in:

=$B$11:$F$16,$I$11:$M$16,$P$11:$T$16,$P$19:$T$24,$I$19:$M$24,$B$19:$F$24,$B$27:$F$32,$I$27:$M$32,$P$27:$T$32


I've shaded these target cells on my own sheet here, but as you can see, any value in these cells that's present on MyValues gets a yellow background and a black border...

...instantaneously.

• Thank you for the response Mat. I am familiar with conditional formatting, but unfortunately I do need the specifics of VBA to allow for more customization. Also, sorry for the case and formatting...I've never had formal coding classes and definitely lack on the finesse. – jb3700 Sep 10 '16 at 16:18

Sticking to VBA, here is my contribution

1. Use built in function

excel or VBA built in functions are much faster then any cells iteration

searching for matching cells is a common Excel task you can accomplish with Find() method

this way you only need to iterate through DateRng cells and search for any matching cell in DateRngPay like follows:

    For Each cell In DateRng '<--| loop through 'DateRng' cells
Set f = DateRngPay.Find(what:=cell.value, LookIn:=xlValues, lookat:=xlWhole) '<--| look in 'DateRngPay' for a cell matching current 'DateRng' one
If Not f Is Nothing Then
With f.Borders
.ColorIndex = 38
.Weight = xlMedium
End With
End If
Next cell


2. Act on grouped cells

acting on many cells one by one is time consuming

so you'd much better group them in one single range object and act on it

you can accomplish this with Excel Union() method like follows:

    Dim unionRng as Range '<--| this range will store all 'DateRng' cells matching any 'DateRng' one
For Each cell In DateRng '<--| loop through 'DateRng' cells
Set f = DateRngPay.Find(what:=cell.value, LookIn:=xlValues, lookat:=xlWhole) '<--| look in 'DateRngPay' for a cell matching current 'DateRng' one
If Not f Is Nothing Then '<--| if a match has been found, then update 'unionRng'
If unionRng Is Nothing Then '<--| if 'unionRng' has already been set
Set unionRng = f
Else
Set unionRng = Union(f, unionRng)
End If
End If
Next cell

If Not unionRng Is Nothing Then '<--| if at least one matching cell has been found, then format them in one shot!
With unionRng.Borders
.ColorIndex = 38
.Weight = xlMedium
End With
End If


where that If unionRng Is Nothing Then takes care not to have Set unionRng = Union(f, unionRng) fail at first matching cell, where unionRng range would still be Nothing: we'll come back here in a while.

3. Summary#1

for what above, a first refactoring of your code could be the following:

Option Explicit

Sub Single1()
Dim DateRng As Range, DateRngPay As Range '<--| working ranges
Dim cell As Range, f As Range '<--| ranges used for lookup tasks
Dim unionRng As Range '<--| this range will store all 'DateRng' cells matching any 'DateRng' one

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")

If ActiveWorkbook.Worksheets("Info").Range("B67") = 1 Then
With DateRng
.Interior.ColorIndex = xlColorIndexNone
.Borders.ColorIndex = 1
.Borders.Weight = xlHairline
For Each cell In .Cells.SpecialCells(xlCellTypeConstants) '<--| loop through 'DateRng' non blank cells
Set f = DateRngPay.Find(what:=cell.value, LookIn:=xlValues, lookat:=xlWhole) '<--| look in 'DateRngPay' for a cell matching current 'DateRng' one
If Not f Is Nothing Then '<--| if a match has been found, then update 'unionRng'
If unionRng Is Nothing Then '<--| if 'unionRng' has already been set
Set unionRng = cell
Else
Set unionRng = Union(cell, unionRng)
End If
End If
Next cell
End With
If Not unionRng Is Nothing Then '<--| if at least one matching cell has been found, then format them in one shot!
With unionRng.Borders
.ColorIndex = 38
.Weight = xlMedium
End With
End If
End If
End Sub


which should already boost it quite up!

But more is yet to come...

4. Avoid useless IF -Then statements

In previous code we have two of such IF statements:

            If Not f Is Nothing Then '<--| if a match has been found, then update 'unionRng'
If unionRng Is Nothing Then '<--| if 'unionRng' has already been set
Set unionRng = cell
Else
Set unionRng = Union(cell, unionRng)
End If
End If


the inner If can be avoided with a little trick:

1. set unionRng just before the For Each cell In DateRng loop:

Set unionRng = somecell '<--| initialize unionRng not to bother about feeding first 'Union()' method with a 'null' range


now you can go straight with Union() method:

    Set unionRng = somecell
For Each cell In .Cells '<--| loop through 'DateRng' cells
Set f = DateRngPay.Find(what:=cell.value, LookIn:=xlValues, lookat:=xlWhole) '<--| look in 'DateRngPay' for a cell matching current 'DateRng' one
If Not f Is Nothing Then Set unionRng = Union(cell, unionRng) '<--| if a match has been found, then update 'unionRng'
Next cell


but here we end up with a false matching cell (i.e.: somecell) in unionRng at the end of the searching loop.

2. initialize unionRng to a range that's certainly outside the looped one (i.e. DateRng):

Set unionRng = DateRng.Offset(-1, -1).Resize(1, 1) '<--| initialize 'unionRng' to a cell out of searched range


this way you just need to use Excel Intersect() method to purge that initializing (and not matching) cell out of unionRng:

Set unionRng = Intersect(unionRng, DateRng.Cells) '<--| "purge" the initializing (and not matching) cell out of 'unionRng'


5. Summary #2

refactoring point 3 code with point 4 technique we come up to:

Option Explicit

Sub Single2()
Dim DateRng As Range, DateRngPay As Range '<--| working ranges
Dim cell As Range, f As Range '<--| ranges used for lookup tasks
Dim unionRng As Range '<--| this range will store all 'DateRng' cells matching any 'DateRng' one

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")

If ActiveWorkbook.Worksheets("Info").Range("B67") = 1 Then
With DateRng
.Interior.ColorIndex = xlColorIndexNone
.Borders.ColorIndex = 1
.Borders.Weight = xlHairline
Set unionRng = DateRng.Offset(-1, -1).Cells(1, 1) '<--| initialize 'unionRng' to a cell out of searched range
For Each cell In .Cells.SpecialCells(xlCellTypeConstants) '<--| loop through 'DateRng' non blank cells
Set f = DateRngPay.Find(what:=cell.value, LookIn:=xlValues, lookat:=xlWhole) '<--| look in 'DateRngPay' for a cell matching current 'DateRng' one
If Not f Is Nothing Then Set unionRng = Union(cell, unionRng) '<--| if a match has been found, then update 'unionRng'
Next cell
Set unionRng = Intersect(unionRng, .Cells) '<--| "purge" the initializing (and not matching) cell out of 'unionRng'
End With
If Not unionRng Is Nothing Then '<--| if at least one matching cell has been found, then format them in one shot!
With unionRng.Borders
.ColorIndex = 38
.Weight = xlMedium
End With
End If
End If
End Sub


6. Do thing when it's time to

doing things before their time is quite a hidden way to consume time uselessly

for instance:

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")

If ActiveWorkbook.Worksheets("Info").Range("B67") = 1 Then


have your code do things (i.e. range settings) even if they should become useless after "Info" sheet "B67" cell check

the correct logic would be:

If ActiveWorkbook.Worksheets("Info").Range("B67") <> 1 Then Exit Sub '<--| exit if "continue" condition isn't met

Set DateRng = ActiveWorkbook.Worksheets("SS").Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")

With DateRng
....


these range settings are quite harmless in this specific case, but keep that in mind and avoid making useless and long calculations (both by excel - changing a worksheet cell in a automatic calculation mode - or by your code - calling some long subs).

7. Avoid processing useless cells

Use SpecialCells() method of Range object to select only its relevant cells to work with

in this specific case we're only interested in numbers (since dates are numbers) so we could filter our working ranges like follows:

Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67").SpecialCells(xlCellTypeConstants, xlNumbers)


8. Miscellanea

Though not being strictly related to the code time performance issue, some coding techniques should be followed to have your code more readable and thus maintainable and upgradeable

which is code performance, too...

Divide et Impera

Romans empire lasted 2 thousands years on this principle, so there must e be something good in it to exploit for us (even if Romans didn't code for PC's...)

your code would be much easier to read both for you and upcoming people if written in such a way as the following:

Sub Main

DoThis

DoThat

End Sub


this would have you really concentrate on relevant bits of your code without a coast-to-coast searching and scrolling of a long code

this will also have the benefit to use variables only when needed and thus both unclutter you code from long variables declaration blocks and improving memory occupation (should that ever be an issue)

for instance, analyzing this declaration block:

Dim DateRng As Range, DateRngPay As Range '<--| working ranges
Dim cell As Range, f As Range '<--| ranges used for lookup tasks
Dim unionRng As Range '<--| this range will store all 'DateRng' cells matching any 'DateRng' one


there would arise the issue we can keep first line in our main sub, while shifting other lines to specific subs/functions

Search for patterns and use them

for instance

.Range("B11:F16,I11:M16,P11:t16,B19:F24,I19:M24,P19:t24,B27:F32,I27:M32,P27:t32,B35:F40,I35:M40,P35:t40")


seems quite a not meaningful range specification while you very well know it does follow a pattern

so use and take advantage of that in your possible future code enhancements

9. Summary# 3

a possible (final?) refactoring could be the following:

Option Explicit

Sub Single3()
Dim DateRng As Range, DateRngPay As Range

If ActiveWorkbook.Worksheets("Info").Range("B67") <> 1 Then Exit Sub '<--| exit if continue condition isn't met

Set DateRng = SetRange(ActiveWorkbook.Worksheets("SS").Range("B11:F16"), 3, 2, 4, 2)
Set DateRngPay = ActiveWorkbook.Worksheets("PS").Range("C2:C67")

FirstFormat DateRng
HighlightCells GetDatesCells(DateRngPay, DateRng.SpecialCells(xlCellTypeConstants, xlNumbers))
End Sub

Function GetDatesCells(DateRngPay As Range, DateRng As Range) As Range
Dim unionRng As Range, f As Range, cell As Range

Set unionRng = DateRng.Offset(-1, -1)
With DateRngPay
For Each cell In DateRng
Set f = .Find(what:=cell.value, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then Set unionRng = Union(unionRng, cell)
Next cell
End With
Set GetDatesCells = Intersect(unionRng, DateRng)
End Function

Sub HighlightCells(rng As Range)
If Not rng Is Nothing Then '<--| if any cell has been found then
With rng.Borders '<--| reference their 'Borders' property
.ColorIndex = 38
.Weight = xlMedium
End With
End If
End Sub

Sub FirstFormat(rng As Range)
With rng
.Interior.ColorIndex = xlColorIndexNone
.Borders.ColorIndex = 1
.Borders.Weight = xlHairline
End With
End Sub

Function SetRange(rng As Range, colsRepeat As Long, colSpacing As Long, rowsRepeat As Long, rowSpacing As Long)
Dim iRow As Long, jCol As Long

Set SetRange = rng
With rng
For iRow = 1 To rowsRepeat
For jCol = 1 To colsRepeat
Set SetRange = Union(SetRange, .Offset((iRow - 1) * (.Rows.Count + rowSpacing), (jCol - 1) * (.Columns.Count + colSpacing)))
Next jCol
Next iRow
End With
End Function


where you are invited to find and use different and more meaningful subs/functions names

Finally, me being a fan of short code, I'd hereby post a possible further shortening of GetDatesCells() sub

Function GetDatesCells(DateRngPay As Range, DateRng As Range) As Range
Dim unionRng As Range, f As Range, cell As Range

Set unionRng = DateRng.Offset(-1, -1)
With DateRngPay
For Each cell In DateRng
If WorksheetFunction.CountIf(.Cells, cell.value) > 0 Then Set unionRng = Union(unionRng, cell)
Next cell
End With
Set GetDatesCells = Intersect(unionRng, DateRng)
End Function

• Wow, that's some epic answer! Lots of good stuff here, well done! – Mathieu Guindon Sep 10 '16 at 17:34
• @Mat'sMug, thank you. Not so sure the OP will come back to this thread, though. – user3598756 Sep 10 '16 at 21:37
• Great post user3598756! I haven't forgot about you... been busy and just trying out each solution now. I've been trying to also figure out some of the bugs myself. So solution 1 works and there is some speed up, but it also highlights any blank cells. Solution 2 throws a application error at set unionRng = dateRng. And Solution 3 states HighlightCells GetDateCells is blank. I don't have any formal training for coding and I may be missing something obvious. I do love to learn so I really appreciate the explanations with your post. – jb3700 Sep 12 '16 at 18:09
• @jb3700, edited solution 1 and 2 to handle (exclude)DateRngblank cells. This has been done by filtering the range with the use of Specialcells() method of Range object. However I can't get you with solution 3 issue: what does " states HighlightCells GetDateCells is blank" mean? – user3598756 Sep 16 '16 at 17:19