4
\$\begingroup\$

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
\$\endgroup\$
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ – fernando.reyes Sep 9 '16 at 21:00
  • \$\begingroup\$ 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 \$\endgroup\$ – jb3700 Sep 9 '16 at 21:12
  • \$\begingroup\$ 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. \$\endgroup\$ – fernando.reyes Sep 9 '16 at 21:21
  • \$\begingroup\$ 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"? \$\endgroup\$ – Mathieu Guindon Sep 9 '16 at 21:26
  • \$\begingroup\$ That's correct Mat... We need to format the SS cell \$\endgroup\$ – jb3700 Sep 9 '16 at 21:28
3
\$\begingroup\$

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!$C$2:$C$67, 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!$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

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.

| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ 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. \$\endgroup\$ – jb3700 Sep 10 '16 at 16:18
2
\$\begingroup\$

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
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ Wow, that's some epic answer! Lots of good stuff here, well done! \$\endgroup\$ – Mathieu Guindon Sep 10 '16 at 17:34
  • \$\begingroup\$ @Mat'sMug, thank you. Not so sure the OP will come back to this thread, though. \$\endgroup\$ – user3598756 Sep 10 '16 at 21:37
  • \$\begingroup\$ 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. \$\endgroup\$ – jb3700 Sep 12 '16 at 18:09
  • \$\begingroup\$ @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? \$\endgroup\$ – user3598756 Sep 16 '16 at 17:19

Your Answer

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

Not the answer you're looking for? Browse other questions tagged or ask your own question.