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