Выполнение пользовательских функций Excel VBA быстрее

Question

У меня есть пользовательская функция, которая используется для подсчета или суммирования количества цветных ячеек, которые у меня есть. Это функция:

Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean) 

    Application.Volatile (True) 

    Dim rCell As Range 
    Dim lCol As Long 
    Dim vResult 

    lCol = rColor.Interior.ColorIndex 

    If SUM = True Then 
     For Each rCell In rRange 
      If rCell.Interior.ColorIndex = lCol Then 
       vResult = WorksheetFunction.SUM(rCell, vResult) 
      End If 
     Next rCell 
    Else 
     For Each rCell In rRange 
      If rCell.Interior.ColorIndex = lCol Then 
       vResult = 1 + vResult 
      End If 
     Next rCell 
    End If 

ColorFunction = vResult 

End Function 

---

Он вызывается путем ввода следующей функции:

=colorfunction($A$1,A2:C2,FALSE) 

или

=colorfunction($A$1,A2:C2,TRUE) 

Где:

• A1 = Ячейка с цветом фона, чтобы проверить
• A2: C2 = Диапазон для подсчета
• FALSE/TRUE, = Count или Sum

---

Мой вопрос: Что я могу делать с VBA для ускорения этой функции?

Я попытался поэкспериментировать с частью WorksheetFunction, но не смог найти синтаксис, который сработал. Любые другие идеи?

Answer 1

Попробуйте:

Function ColorFunction2(rColor As Range, rRange As Range, _ 
         Optional pSUM As Boolean) As Variant 
Dim rCell As Range 
Dim lCol As Long 
Dim vResult As Variant, vTmp As Variant ' for intermediate calcs, _ 
              for clear vision of logic, _ 
              for not doubling code 
    Application.Volatile (True) 

    lCol = rColor.Interior.ColorIndex 

    For Each rCell In rRange.Cells ' expicit .Cells 
     If rCell.Interior.ColorIndex = lCol Then 
      Select Case pSUM ' SUM is reserved word 
       Case True: vTmp = rCell.Value ' out of sheet functions calling 
       Case False: vTmp = 1 
     ' change True-False sequence according to real probability they occures 
      End Select 
     End If 
     vResult = vResult + vTmp 
    Next ' rCell ' No need 

    ColorFunction2 = vResult 
End Function 

Добавлена ​​expicit "как вариант"