Comparing dates from sheets

Question

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

• fernando.reyes: 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
• jb3700: 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
• fernando.reyes: 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.
• Mathieu Guindon: 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"?
• jb3700: That's correct Mat... We need to format the SS cell

Answer 1

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.

Ready?

---

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!$C2ドル:$C67ドル, say MyValues - here I've populated the data with values 1-66, but anything will do:

named range

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

=AND(Info!$B67ドル=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:

=$B11ドル:$F16,ドル$I11ドル:$M16,ドル$P11ドル:$T16,ドル$P19ドル:$T24,ドル$I19ドル:$M24,ドル$B19ドル:$F24,ドル$B27ドル:$F32,ドル$I27ドル:$M32,ドル$P27ドル:$T32ドル

conditional format

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

conditional formats

...instantaneously.

• jb3700: 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.

Answer 2

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

this, again, to improve code readability, maintenance and upgrading:

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

• Mathieu Guindon: Wow, that's some epic answer! Lots of good stuff here, well done!
• user3598756: @Mat'sMug, thank you. Not so sure the OP will come back to this thread, though.
• jb3700: 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.
• user3598756: @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?