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

Question

我有一个带有主控制表和 40-50 个不同的数据表的工作簿，这些数据表从外部来源复制/粘贴到文件中（每个工作表都有 30 到 500 行和 10 到 100 列的数据） .

工作簿的目的是比较各个数据表列中的单元格，如果它们符合某个方差标准，则突出显示它们；然后计算每个数据表上突出显示的单元格并显示在主控制表上（使用 UDF 公式）。

阅读 cpearson 网站后，我意识到如果您使用传统的条件格式，计算突出显示的单元格几乎是不可能的......但我只是在我已经在 VBA 中编写了 40 多张纸的自定义 CF 代码之后才知道这一点（这个这样做是为了在使用复制/粘贴“刷新”数据表后，可以使用宏按钮删除或应用格式）。

因此，经过长时间的哭泣，我基本上使用循环重新创建了条件格式（再次在 VBA 中）以实现我的目标。

---

示例标准：小于或大于比较单元格值的 25%。

示例数据表：

[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

示例代码：

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

（填充的数据列和分散在工作表中的隐藏行之间通常有空白列）

然后我创建了一个 UDF 以满足我的计数需求：

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

我有两个主要问题：

1. 应用条件格式时，显示 UDF 公式 (=CountRed[WkshtName]{Range:Range}) 的单元格不会自动更新；即使 UDF 的“application.volatile”处于活动状态并且工作簿设置为自动计算也是如此。

2. 速度。

考虑到这两个条件（application.volatile 和自动计算），突出显示的单元格计数（UDF 公式的输出）只有在我单击 UDF 公式单元格之一并按 F9 时才会更新（或者我可以单击公式栏并按回车键），但更大的问题是我的工作簿在更新页面上的所有 UDF 公式时会超时 4-5 分钟（这是我的假设，基于更快的处理时间和更少的 UDF 公式在页面上或 UDF 公式中使用的较小范围标准）。 *关闭 application.volatile 并保留自动计算会产生类似的结果。

为了解决这个问题，我关闭了自动计算和 application.volatile（这似乎没有任何效果）。

我知道这种方法不允许对输出 UDF 公式（突出显示的单元格计数）进行任何类型的自动更新，但每个 UDF 公式的手动重新计算（F9 或公式“输入”）现在只需要 5-10秒取决于范围大小（它也只会更新您单击的单元格）。

当我尝试包含一个单击按钮宏来强制更新整个页面以消除更新每个 UDF 公式单元格的需要时，我的主要问题发生了（例如 ThisWorkbook.Worksheets("Reference").Calculate），然后，我的计算时间会减慢到接近原始更新时间（3-4 分钟），这让我怀疑它是否真的快得多。

所有这些都让我问...

有什么方法可以优化或加快我的自定义 UDF 的循环/处理时间？

自动更新将是锦上添花，但如果我必须强制手动重新计算，那么我希望它尽可能快。

---

如果我需要澄清任何事情，或截取我的工作簿/代码的屏幕截图，请告诉我（如果我的解释相当复杂，我提前道歉；我使用 VBA 的时间有限，当然我还是个新手)。

注意：我使用的是 Excel 2007。

提前谢谢你！！

Answer 1

您的代码很慢，因为您参考 Excel 来检查区域中的每个单元格。最有效的方法是将使用的范围加载到 VBA 内存中并使用这些数组 - 查看这组文章 - 它非常有用并且写得很好 https://fastexcel.wordpress.com/making-your-vba-udfs-efficient/

也为了更快的计算 - 您可以计算工作表的范围，无需重新计算所有工作表。

希望对你有帮助

Answer 2

您可以在为彩色单元格着色时保留计数，然后使用该值，而不是在单独的操作中计算彩色单元格。

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