VBA-优化UDF（单元格颜色计数器）

Question

I have a workbook with a main control sheet and 40-50 different data sheets that are copy/paste valued into the file from an external source (each sheet has anywhere from 30 to 500 rows and 10 to 100 columns with data).

The purpose of the workbook is to compare cells in various data sheet columns and highlight them if they fit a certain variance criteria; the highlighted cells on each data sheet are then counted and displayed on the main control sheet (using UDF formulas).

After reading the cpearson site, I realized that counting highlighted cells was nearly impossible if you used traditional conditional formatting... but I only figured this out after I had already written the custom CF code in VBA for 40+ sheets (this was done so that formatting could be removed or applied with a macro button after the data sheets had been "refreshed" using copy/paste).

So after a nice long cry, I essentially recreated conditional formatting (again in VBA) using looping to achieve my goal.

---

Example criteria: 25% less than or greater than the cell value compared.

Example Data Sheet:

[col 1] *** [col 2]
2014 *****2015
1 *********1.1
3 **********3
532 *******555
323 *******46 <<<this would Highlight
42 *******-112 <<<<this would highlight

(The highlighting would occur if cells in col 2 are either 25% greater or
 less than the cells in col 1 cell for the corresponding row.)

asterisks are only used for the purpose of spacing the two columns in this example

Example code:

Dim ref As WorksheetDim wkb As Workbook

Set wkb = ThisWorkbook
Set ref = ThisWorkbook.Sheets("Reference")
pn1 = ref.Range("E17").Value


With wkb.Sheets(pn1)
.Select

Set e1 = wkb.Sheets(pn1)

 For i = 7 To 53
 j = 2
 k = j + 8


    If e1.Cells(i, j).Value > 0 And IsNumeric(e1.Cells(i, j).Value) = True _
    Then If e1.Cells(i, j).Value > 1.25 * e1.Cells(i, k).Value _
Or e1.Cells(i, j).Value < 0.75 * e1.Cells(i, k).Value _
    Then e1.Cells(i, j).Interior.Color = RGB(252, 213, 181)


If e1.Cells(i, j).Value < 0 And IsNumeric(e1.Cells(i, j).Value) = True _
    Then If e1.Cells(i, j).Value < 1.25 * e1.Cells(i, k).Value _
Or e1.Cells(i, j).Value > 0.75 * e1.Cells(i, k).Value _
    Then e1.Cells(i, j).Interior.Color = RGB(252, 213, 181)

Next i

  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  For i = 7 To 53
  j = 2
  k = j + 9


If e1.Cells(i, j).Value > 0 And IsNumeric(e1.Cells(i, j).Value) = True _
    Then If e1.Cells(i, j).Value > 1.25 * e1.Cells(i, k).Value _
Or e1.Cells(i, j).Value < 0.75 * e1.Cells(i, k).Value _
    Then e1.Cells(i, j).Interior.Color = RGB(252, 213, 181)


If e1.Cells(i, j).Value < 0 And IsNumeric(e1.Cells(i, j).Value) = True _
    Then If e1.Cells(i, j).Value < 1.25 * e1.Cells(i, k).Value _
Or e1.Cells(i, j).Value > 0.75 * e1.Cells(i, k).Value _
    Then e1.Cells(i, j).Interior.Color = RGB(252, 213, 181)

Next i


End With

End Sub

(There are often blank columns between populated data columns and hidden rows scattered throughout the sheets)

I then created a UDF to fit my counting needs:

Function CountRed(MyRange As Range) As Integer                                       
'Application.Volatile                                                          
CountRed = 0                                                                    
For Each cell In MyRange                                                        
If Not cell.EntireRow.Hidden And cell.Interior.Color = RGB(252, 213, 181) 
CountRed = CountRed + 1                                                         
End If                                                                          
Next cell
End Function

I have two main issues:

1. When the conditional formatting is applied, the cell displaying the UDF formula (=CountRed[WkshtName]{Range:Range}) does not automatically update; this being the case even if "application.volatile" is active for the UDF and the workbook is set to automatic calculation.

2. Speed.

With these two conditions in mind (application.volatile and automatic calculation), the highlighted cell count number (output of the UDF formula) will only update if I click one of the UDF formula cells and press F9 (or I can click the formula bar and press enter), but the bigger problem is that my workbook times out for a solid 4-5 minutes while it updates ALL of the UDF formulas on my page (this is my assumption based on quicker processing times with less UDF formulas on the page or smaller range criteria used in the UDF formulas). *Turning off application.volatile and leaving automatic calculation on yields similar results.

To combat this I have turned OFF both automatic calculation and application.volatile (this seemingly has no effect either way).

I know this method will not allow for any type of automatic updating of the output UDF formula (highlighted cell count number), but the manual recalculation (F9 or formula "enter") of each UDF formula now only takes 5-10 seconds depending on the range size (it will also only update the cell you clicked on).

My main hiccup here occurs when I try and include a click button macro that forces an update of the whole page to eliminate the need for updating each UDF formula cell (ex. ThisWorkbook.Worksheets("Reference").Calculate), my calculation time then slows back down near the original updating times (3-4 minutes) and leaves me questioning if it is really that much faster after all.

All of that leads me to ask...

Is there was any way to optimize or speed up the looping/processing time of my custom UDF?

Automatic updating would be icing on the cake, but if I have to force a manual recalculation then I would love for it to be as fast as possible.

---

Please let me know if I need to clarify anything, or take screen shots of my workbook/code (I apologize in advance if my explanation is fairly convoluted; I have been using VBA for a limited time and am certainly still a novice).

Note: I am using Excel 2007.

THANK YOU IN ADVANCE !!

Answer 1

Your code is slow because you refer to Excel to check each cell in the range. The most efficient way would be to load the used range into VBA memory and working with those arrays - check this set of articles - it's extremely useful and well written https://fastexcel.wordpress.com/making-your-vba-udfs-efficient/

Also for faster calculation - you can calculate a range of the worksheet, no need to recalc all sheet.

Hope this helps

Answer 2

You can keep a count of the colored cells as you color them, then use that value, instead of counting the colored cells in a separate operation.

Sub DoColors()

    Dim ref As Worksheet, e1 As Worksheet
    Dim wkb As Workbook, pn1
    Dim rw As Range, i As Long, j As Long, n As Long, v, v2, v3

    Set wkb = ThisWorkbook
    Set ref = wkb.Sheets("Reference")
    pn1 = ref.Range("E17").Value

    Set e1 = wkb.Sheets(pn1)

    j = 2
    n = 0
    For i = 7 To 53

        Set rw = e1.Rows(i)

        v = rw.Cells(j).Value

        If IsNumeric(v) And v > 0 Then

            v2 = rw.Cells(j + 8).Value
            v3 = rw.Cells(j + 9).Value

            If Abs(v - v2) / v2 > 0.25 Or Abs(v - v3) / v3 > 0.25 Then
                rw.Cells(j).Interior.Color = RGB(252, 213, 181)
                n = n + 1
            End If

        End If
    Next i

    'put n somewhere...

End Sub