ColorFunction UDF [英] ColorFunction UDF

问题描述

我已经尝试了3种不同类型的可用于我的Excel 2013的在线可用的UDF。但是，每次刷新等时，它都会崩溃...有一个修复可以阻止（只有在完成后才能刷新它手动）

Hi I have tried 3 different types of colorfunction UDF that are available online for my Excel 2013. However it keeps crashing every time I refresh etc... there was a fix to stop this (for excel to refresh it only if done manually)

这是代码：

    Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean)
    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

请帮助，因为这真的很烦人，我的整个电脑崩溃...

Please help as this is getting really annoying, my whole computer crashes...

这可以放在一个宏中，我可以手动运行吗？会解决吗？

Could this be put into a macro that I can run manually? would that solve it?

额外的信息 - 运行Windows 8.1 ... Office 2013 ... Ive已经尝试在三台不同的电脑上运行一样，同样也发生了在2010版本的办公室在Windows 7上。只是崩溃的excel试图更新（可能有太多的记录，但它们包含大约100行，这应该是可以的）

Extra information - running windows 8.1... Office 2013... Ive already tried running on three different computers all the same, the same also happened on 2010 version of office on windows 7. Just crashes excel trying to update (possibly too many records but they contain around 100 rows, which should be ok?)

尝试以下，也崩溃了excel。 CALCULATING（3 PRCOESSOR（S））; 0％

tried the following which also crashes excel. Just says CALCULATING( 3 PRCOESSOR(S)); 0%

    Function CountCellsByColor(rData As Range, cellRefColor As Range) As Long
    Dim indRefColor As Long
    Dim cellCurrent As Range
    Dim cntRes As Long

    Application.Volatile
    cntRes = 0
    indRefColor = cellRefColor.Cells(1, 1).Interior.Color
    For Each cellCurrent In rData
        If indRefColor = cellCurrent.Interior.Color Then
            cntRes = cntRes + 1
        End If
    Next cellCurrent

    CountCellsByColor = cntRes
End Function

---

它最终做的工作，但每个至少3个小时需要相当多的时间...所以当它尝试更新40个字段与颜色功能在

---

It eventually does work but it takes a considerable time for each one at least 3 minuites... So the whole thing crashes when it tries to update 40 fields with colorfunctions in

查看任务管理器并关注等待链，这是否是splwow64.exe的任何想法，如果这是问题？

Looking in task manager and following the wait chain, it comes to splwow64.exe any ideas if this is the issue?

推荐答案

我会说很可能你有另一个事件被触发，并且进入一个无休止或非常广泛的循环。

I'd say it's highly likely you have another event being triggered and are entering an endless or very extensive loop.

通过禁用应用程序事件来测试它，看看你的函数是否运行得更快。我已经弄清了你的代码，并给出了一个例子，说明如何禁用测试的事件。当然，请记住在完成后启用事件。

Test it by disabling the application events and see if your function runs any quicker. I've tidied up your code a little and given an example in it of how to disable the events for your testing. Of course, remember to enable the events when you're done.

Public Function ColorFunction(rColor As Range, rRange As Range, Optional isAggregating As Boolean) As Variant
    Dim rCell As Range
    Dim iRefColourIndex As Integer
    Dim result As Variant

    'Try toggling this line false and true.
    'If there's a big speed difference then you must have a _Change event causing you trouble.
    Application.EnableEvents = False

    iRefColourIndex = rColor.Interior.ColorIndex
    result = 0
    For Each rCell In rRange.Cells
        If rCell.Interior.ColorIndex = iRefColourIndex Then
            If isAggregating And IsNumeric(rCell.Value2) Then
                result = result + rCell.Value2
            Else
                result = result + 1
            End If
        End If
    Next

    ColorFunction = result

End Function

这篇关于ColorFunction UDF的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！