Faster Cycle through Cells

[Tod]

I've been given a workbook that creates reports and asked
if I can make it run faster. I've managed to get it down
from 1 hour and 40 minutes running time to just under 20
minutes just by cleaning up the code. I imagine they'd be
jumping for joy just at 20 minutes, but I want more!

Part of the code creates a new worksheet, dumps data from
an ADO recordset into the sheet, then color codes a
column of values based on the value in the cell. There
are six different colors that it could be. The only slow
part left of the entire thing is this cycling cells and
coloring based on values. Currently it is something like
this:

For each Cell in mySheet.Range("A2:A" & mySheet.Range
("A65536").End(xlUp).Row
Select Case Cell.Value
Case "ValueA"
Cell.Interior.ColorIndex = 13
Case "ValueB"
Cell.Interior.ColorIndex = 5
Case "ValueC"
Cell.Interior.ColorIndex = 10
Case "ValueD"
Cell.Interior.ColorIndex = 6
Case "ValueE"
Cell.Interior.ColorIndex = 45
Case Else
Cell.Interior.ColorIndex = 3
End Select
Next Cell

Is there a faster way?

 

[Jim Cone]

Tod,

Couple of quick thoughts...

The list of cases should be in order of use with the
most frequent value at the top.

Color all of the cells in the loop range to ColorIndex 3,
before running the loop, and eliminate the last case
from the Select Case statement.

Regards,
Jim Cone
San Francisco, USA

 

[Bob Phillips]

Have you done the usuals such as turning screenupdating off, and setting
manual calculation mode at the start?

Also, set up colour constants and use these.

--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Phillip]

Tod
I tested this code with 3 fields and 1000 records with 3 field
headers covering the range A1:C1001
The third field held the 6 values you mentioned in random order
The three fields were named FieldA, FieldB and FieldC
This procedure takes under a second to process 1000 records in FieldC
You will have to range name the field you want to process
after the ADO recordset is loaded using VBA. i.e Range C1:C1001 is
named FieldC
In my example the naming process is not shown
Note that V=Array statement has been split into 2 lines for ease of
reading but it should be all one line

'Put this in a standard module

Option Base 1 'put as first line of module

Sub DoFilter()
Dim v As Variant
Dim z As Variant
Dim x As Integer
Dim Rng As Range

Set Rng = Range("FieldC")
v = Array("ValueA", "ValueB", "ValueC", _
"ValueD", "ValueE", "ValueF")
z = Array(13, 5, 10, 6, 45, 3) 'list of colours
Rng.Cells(2).Select
With Selection
..AutoFilter 'turn on filter
For x = 1 To 6
..AutoFilter Field:=3, Criteria1:=v(x)
Rng.Select
DoFormat z(x)
Next
..AutoFilter 'turn off filter
End With
End Sub

Sub DoFormat(ByVal Colour As Integer)
Selection.SpecialCells(xlCellTypeVisible).Select
With Selection
..FormatConditions.Delete
..FormatConditions.Add Type:=xlExpression, Formula1:="TRUE"
..FormatConditions(1).Interior.ColorIndex = Colour
End With
End Sub

 

[Guest]

Hi Tod,

I believe the following methodology would run a lot quicker.

1. Add a temporary column alongside your existing column(s). Use AutoFill
(or an array) to populate that column with numbers from 1 to
NumberOfRows.

2. Sort on Column A to arrange all ValueA's & ValueB's etc into contiguous
blocks.

3. Use Find (and logic) to locate the first & last cells of each ValueX
block.

4. Format each block using syntax like Range(FirstCell,LastCell).Interior...

5. Resort on the temporary column to get your rows back into original order,
then delete the temp column.


Regards,
Vic Eldridge

 

[keepITcool]

Phillip,

what's the point of using formatconditions when you do not use them?
it will just make the sheet slow and setting the interior.fill
accomplishes the same.

Following should work more efficient (10000 rows: 337ms vs 4318ms)


Sub DoFilter()
Dim arr(1 To 2) As Variant
Dim rng(1 To 2) As Range
Dim i%

Application.ScreenUpdating = False
arr(1) = Array("ValueA", "ValueB", "ValueC", _
"ValueD", "ValueE", "ValueF")
arr(2) = Array(13, 5, 10, 6, 45, 3)

Set rng(1) = Range("FieldC")
Set rng(1) = Intersect(rng(1), rng(1).Parent.UsedRange)
rng(1).Interior.ColorIndex = xlNone

With rng(1)(1, 1)
..AutoFilter 'turn on filter
For i = LBound(arr(1)) To UBound(arr(1))
..AutoFilter Field:=3, Criteria1:=arr(1)(i)
On Error Resume Next
Set rng(2) = Intersect(.SpecialCells(xlCellTypeVisible), rng(1))
On Error GoTo 0
If Not rng(2) Is Nothing Then rng(2).Interior.ColorIndex = arr(2)(i)
Next
..AutoFilter 'turn off filter
..Interior.ColorIndex = xlNone
End With

Application.ScreenUpdating = True
End Sub


--
keepITcool
| www.XLsupport.com | keepITcool chello nl | amsterdam


Phillip wrote :