VBA实用小程序79：统计不同值或唯一值的VBA自定义函数
excelperfect
在文章开始之前，解释一下什么是不同值？什么是唯一值？
例如，下面的一组数据：
a,a,b,b,c,d,e,e,f
我们说，这组数据有6个不同值：a,b,c,d,e,f；有3个唯一值：c,d,f，因为它们在列表中只出现了1次。
我们要求这组数据中不同值的数量，可以使用数组公式：
=SUM(--(FREQUENCY(IF(A1:A9<>'',MATCH('~'& A1:A9,A1:A9&'',0)),ROW(A1:A9)-ROW(A1)+1)>0))
结果如下图1所示。
图1
然而，这个公式不仅复杂，而且在处理混合数据时会很慢。因此，我们可以使用VBA来编写自定义函数。
使用Collection对象来统计不同值
代码如下：
Public Function COUNTDISTINCTcol(ByRef rngToCheck As Range) As VariantDim colDistinct As CollectionDim varValues As VariantDim varValue As VariantDim lngCount As LongDim lngRow As LongDim lngCol As LongOn Error GoTo ErrorHandlervarValues= rngToCheck.Value'如果rngToCheck多于1个单元格'那么varValues是一个二维数组If IsArray(varValues) ThenSet colDistinct = New CollectionFor lngRow = LBound(varValues, 1) To UBound(varValues, 1)For lngCol = LBound(varValues, 2) To UBound(varValues, 2)varValue = varValues(lngRow, lngCol)'忽略空单元格'如果单元格包含错误值则触发错误If LenB(varValue) > 0 Then'如果该项已存在则会触发错误'忽略该错误On Error Resume NextcolDistinct.Add vbNullString, CStr(varValue)On Error GoTo ErrorHandlerEnd IfNext lngColNext lngRowlngCount = colDistinct.CountElseIf LenB(varValues) > 0 ThenlngCount = 1End IfEnd IfCOUNTDISTINCTcol = lngCountExit FunctionErrorHandler:COUNTDISTINCTcol = CVErr(xlErrValue)End Function集合中的每个项目都必须具有唯一键，并且该唯一键必须是字符串。如果代码尝试创建重复键，则会引发错误。由于OnError Resume Next语句，该错误被忽略。VBACollection 对象的一个特性是键不区分大小写。
LenB函数用于检查单元格是否为空白。如果单元格包含错误值，则此时将引发错误并且自定义函数将返回#VALUE!。空单元格意味着：
单元格中什么也没有
有一个零长字符串
仅仅有一个前缀符号（通常是’）
使用Dictionary对象来统计不同值
在编写代码前，先添加对MicrosoftScripting Runtime库的引用。在VBE中，单击“工具——引用”，找到并勾选“MicrosoftScripting Runtime”，如下图2所示。
图2
代码如下：
Public Function COUNTDISTINCTdicNew(ByRef rngToCheck As Range) As Variant '早期绑定 '需要引用Microsoft Scripting Runtime库 Dim dicDistinct As Scripting.Dictionary Dim varValues As Variant Dim varValue As Variant Dim lngCount As Long Dim lngRow As Long Dim lngCol As Long Dim strValue As String On Error GoTo ErrorHandler varValues= rngToCheck.Value '如果rngToCheck多于1个单元格 '那么varValues是一个二维数组 If IsArray(varValues) Then Set dicDistinct = CreateObject('Scripting.Dictionary') dicDistinct.CompareMode = TextCompare For lngRow = LBound(varValues, 1) To UBound(varValues, 1) For lngCol = LBound(varValues, 2) To UBound(varValues, 2) varValue = varValues(lngRow, lngCol) '忽略空单元格 '如果单元格包含错误值则触发错误 If LenB(varValue) > 0 Then '将所有内容转换为字符串 '字典对类型不敏感 strValue = CStr(varValue) If Not dicDistinct.Exists(strValue) Then dicDistinct.Add strValue, vbNullString End If End If Next lngCol Next lngRow lngCount = dicDistinct.Count Else If LenB(varValues) > 0 Then lngCount = 1 End If End If COUNTDISTINCTdicNew = lngCount Exit FunctionErrorHandler: COUNTDISTINCTdicNew = CVErr(xlErrValue)End Function这段代码在第一次调用后保留现有Dictionary对象并随后清除。使用Static关键字代替Dim，以便在函数调用之间保留Dictionary对象引用：
Public Function COUNTDISTINCTdicStatic(ByRef rngToCheck As Range) As VariantStatic dicDistinct As Scripting.DictionaryDim varValues As VariantDim varValue As VariantDim lngCount As LongDim lngRow As LongDim lngCol As LongDim strValue As StringOn Error GoTo ErrorHandlervarValues= rngToCheck.Value'如果rngToCheck多于1个单元格'那么varValues是一个二维数组If IsArray(varValues) ThenIf dicDistinct Is Nothing ThenSet dicDistinct = CreateObject('Scripting.Dictionary')dicDistinct.CompareMode = TextCompareElsedicDistinct.RemoveAllEnd IfFor lngRow = LBound(varValues, 1) To UBound(varValues, 1)For lngCol = LBound(varValues, 2) To UBound(varValues, 2)varValue = varValues(lngRow, lngCol)'忽略空单元格'如果单元格包含错误值则触发错误If LenB(varValue) > 0 Then'将所有内容转换为字符串'字典对类型不敏感strValue = CStr(varValue)If Not dicDistinct.Exists(strValue) ThendicDistinct.Add strValue, vbNullStringEnd IfEnd IfNext lngColNext lngRowlngCount = dicDistinct.CountElseIf LenB(varValues) > 0 ThenlngCount = 1End IfEnd IfCOUNTDISTINCTdicStatic = lngCountExit FunctionErrorHandler:COUNTDISTINCTdicStatic = CVErr(xlErrValue)End Function下面是上述方式统计不同值的结果，如下图3所示。
图3
正如所看到的，这4个公式都对数据类型不敏感，也对大小写不敏感。
扩展的不同值统计——Dictionary对象
代码如下：
Public Function COUNTDISTINCT(ByRef rngToCheck AsRange, _ Optional ByVal blnCaseSensitive As Boolean = True) As Variant Static dicDistinctAs Scripting.Dictionary Dim varValues As Variant Dim varValue As Variant Dim lngCount As Long Dim lngRow As Long Dim lngCol As Long On Error GoTo ErrorHandler Set rngToCheck = Intersect(rngToCheck.Worksheet.UsedRange, rngToCheck) If No trngToCheck Is Nothing Then '将单元格值分配到内存中 '以便更快地使用它们 varValues = rngToCheck.Value '如果rngToCheck多于1个单元格 '那么varValues是一个二维数组 If IsArray(varValues) Then If dicDistinct Is Nothing Then Set dicDistinct = CreateObject('Scripting.Dictionary') dicDistinct.CompareMode = BinaryCompare Else dicDistinct.RemoveAll End If For lngRow = LBound(varValues, 1) ToUBound(varValues, 1) For lngCol = LBound(varValues, 2) To UBound(varValues, 2) varValue = varValues(lngRow, lngCol) '忽略错误值 If Not IsError(varValue) Then '忽略空单元格 '包括公式返回的'' If LenB(varValue) >0 Then '如果是字符串 '那么允许区分大小写 If VarType(varValue) = vbString Then If Not blnCaseSensitive Then varValue =UCase(varValue) End If End If If Not dicDistinct.Exists(varValue)Then dicDistinct.AddvarValue, vbNullString End If End If End If Next lngCol Next lngRow lngCount = dicDistinct.Count Else '如果单元格包含错误或为空则忽略 If Not IsError(varValues) Then If LenB(varValues) > 0 Then lngCount = 1 End If End If End If End If COUNTDISTINCT = lngCount Exit FunctionErrorHandler: COUNTDISTINCT = CVErr(xlErrValue)End Function注意以下几点：
可以统计数字、文本和逻辑数据类型，但会忽略错误值，例如#N/A和DIV/0!。
忽略空（和空白）单元格。
默认情况下区分大小写。
区分数据类型。例如，这两个公式将被认为是不同的：=TRUE()和='True'，就像 ='1' 和 =1。
需要对 MicrosoftScripting Runtime 库的引用。如果不包含引用，则需要将Dictionary 对象声明为 Object类型，并将BinaryCompare设置为等于0的常量。
可以处理跨多列的数据。
示例如下图4所示。
图4
扩展的唯一值统计——Dictionary对象
与上面的代码相似：
Public Function COUNTUNIQUE(ByRef rngToCheck AsRange, _Optional ByVal blnCaseSensitive As Boolean = True) As VariantStatic dicDistinct As ObjectDim varValues As VariantDim varValue As VariantDim varItems As VariantDim lngCount As LongDim lngItem As LongDim lngRow As LongDim lngCol As LongOn Error GoTo ErrorHandlerSet rngToCheck = Intersect(rngToCheck.Worksheet.UsedRange, rngToCheck)If Not rngToCheck Is Nothing Then'将单元格值分配到内存中'以便更快地使用它们varValues = rngToCheck.Value'如果rngToCheck多于1个单元格'那么varValues是一个二维数组If IsArray(varValues) ThenIf dicDistinct Is Nothing ThenSet dicDistinct = CreateObject('Scripting.Dictionary')dicDistinct.CompareMode = BinaryCompareElsedicDistinct.RemoveAllEnd IfFor lngRow = LBound(varValues, 1) To UBound(varValues, 1)For lngCol = LBound(varValues, 2) To UBound(varValues, 2)varValue = varValues(lngRow, lngCol)'忽略错误值If Not IsError(varValue) Then'忽略空单元格'包括公式返回的''If LenB(varValue) >0 Then'如果是字符串'那么允许区分大小写If VarType(varValue) = vbString ThenIf NotblnCaseSensitive ThenvarValue =UCase(varValue)End IfEnd If'如果已存在则统计其出现了多少次If dicDistinct.Exists(varValue) ThendicDistinct.Item(varValue) = dicDistinct.Item(varValue) + 1Else'添加其出现1次dicDistinct.AddvarValue, 1End IfEnd IfEnd IfNext lngColNext lngRow'仅对出现一次的项varItems = dicDistinct.ItemsFor lngItem = LBound(varItems, 1) To UBound(varItems, 1)If varItems(lngItem) = 1 ThenlngCount = lngCount + 1End IfNext lngItemElse'如果单元格包含错误或为空则忽略If Not IsError(varValues) ThenIf LenB(varValues) > 0 ThenlngCount = 1End IfEnd IfEnd IfEnd IfCOUNTUNIQUE = lngCountExit FunctionErrorHandler:COUNTUNIQUE = CVErr(xlErrValue)End Function结果如下图5所示。
图5
注：本文整理自colinlegg.wordpress.com，供有兴趣的朋友学习参考。
赞 (0)