VBA实用小程序79：统计不同值或唯一值的VBA自定义函数

2021-07-12 16:09:56 浏览数 (1)

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对象来统计不同值

代码如下：

代码语言：javascript复制
Public Function COUNTDISTINCTcol(ByRef rngToCheck As Range) As Variant
    Dim colDistinct As Collection
    Dim varValues As Variant
    Dim varValue As Variant
    Dim lngCount As Long
    Dim lngRow As Long
    Dim lngCol As Long
   
    On Error GoTo ErrorHandler
   
    varValues= rngToCheck.Value
   
   '如果rngToCheck多于1个单元格
   '那么varValues是一个二维数组
    If IsArray(varValues) Then
        Set colDistinct = New Collection
        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
                    '如果该项已存在则会触发错误
                    '忽略该错误
                   On Error Resume Next
                   colDistinct.Add vbNullString, CStr(varValue)
                   On Error GoTo ErrorHandler
               End If
           Next lngCol
        Next lngRow
       lngCount = colDistinct.Count
    Else
        If LenB(varValues) > 0 Then
           lngCount = 1
        End If
    End If
   COUNTDISTINCTcol = lngCount
    Exit Function
ErrorHandler:
   COUNTDISTINCTcol = CVErr(xlErrValue)
End Function

集合中的每个项目都必须具有唯一键，并且该唯一键必须是字符串。如果代码尝试创建重复键，则会引发错误。由于OnError Resume Next语句，该错误被忽略。VBACollection 对象的一个特性是键不区分大小写。

LenB函数用于检查单元格是否为空白。如果单元格包含错误值，则此时将引发错误并且自定义函数将返回#VALUE!。空单元格意味着：

  • 单元格中什么也没有
  • 有一个零长字符串
  • 仅仅有一个前缀符号（通常是’）

使用Dictionary对象来统计不同值

在编写代码前，先添加对MicrosoftScripting Runtime库的引用。在VBE中，单击“工具——引用”，找到并勾选“MicrosoftScripting Runtime”，如下图2所示。

图2

代码如下：

代码语言：javascript复制
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 Function
ErrorHandler:
   COUNTDISTINCTdicNew = CVErr(xlErrValue)
End Function

这段代码在第一次调用后保留现有Dictionary对象并随后清除。使用Static关键字代替Dim，以便在函数调用之间保留Dictionary对象引用：

代码语言：javascript复制
Public Function COUNTDISTINCTdicStatic(ByRef rngToCheck As Range) As Variant
    Static 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
        If dicDistinct Is Nothing Then
           Set dicDistinct = CreateObject("Scripting.Dictionary")
           dicDistinct.CompareMode = TextCompare
        Else
           dicDistinct.RemoveAll
        End If
       
        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
   COUNTDISTINCTdicStatic = lngCount
    Exit Function
ErrorHandler:
   COUNTDISTINCTdicStatic = CVErr(xlErrValue)
End Function

下面是上述方式统计不同值的结果，如下图3所示。

图3

正如所看到的，这4个公式都对数据类型不敏感，也对大小写不敏感。

扩展的不同值统计——Dictionary对象

代码如下：

代码语言：javascript复制
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 Function
ErrorHandler:
   COUNTDISTINCT = CVErr(xlErrValue)
End Function

注意以下几点：

  • 可以统计数字、文本和逻辑数据类型，但会忽略错误值，例如#N/A和DIV/0!。
  • 忽略空（和空白）单元格。
  • 默认情况下区分大小写。
  • 区分数据类型。例如，这两个公式将被认为是不同的：=TRUE()和="True"，就像 ="1" 和 =1。
  • 需要对 MicrosoftScripting Runtime 库的引用。如果不包含引用，则需要将Dictionary 对象声明为 Object类型，并将BinaryCompare设置为等于0的常量。
  • 可以处理跨多列的数据。

示例如下图4所示。

图4

扩展的唯一值统计——Dictionary对象

与上面的代码相似：

代码语言：javascript复制
Public Function COUNTUNIQUE(ByRef rngToCheck AsRange, _
    Optional ByVal blnCaseSensitive As Boolean = True) As Variant
    Static dicDistinct As Object
    Dim varValues As Variant
    Dim varValue As Variant
    Dim varItems As Variant
    Dim lngCount As Long
    Dim lngItem As Long
    Dim lngRow As Long
    Dim lngCol As Long
       
    On Error GoTo ErrorHandler
   
    Set rngToCheck = Intersect(rngToCheck.Worksheet.UsedRange, rngToCheck)
   
    If Not rngToCheck 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) 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 Then
                                If NotblnCaseSensitive Then
                                    varValue =UCase(varValue)
                                End If
                            End If
 
                            '如果已存在则统计其出现了多少次
                            If dicDistinct.Exists(varValue) Then
                               dicDistinct.Item(varValue) = dicDistinct.Item(varValue)   1
                            Else
                                '添加其出现1次
                                dicDistinct.AddvarValue, 1
                            End If
                        End If
                   End If
                Next lngCol
           Next lngRow
       
            '仅对出现一次的项
           varItems = dicDistinct.Items
           For lngItem = LBound(varItems, 1) To UBound(varItems, 1)
               If varItems(lngItem) = 1 Then
                   lngCount = lngCount   1
               End If
           Next lngItem
           
        Else
            '如果单元格包含错误或为空则忽略
           If Not IsError(varValues) Then
               If LenB(varValues) > 0 Then
                   lngCount = 1
                End If
           End If
        End If
    End If
   COUNTUNIQUE = lngCount
    Exit Function
ErrorHandler:
   COUNTUNIQUE = CVErr(xlErrValue)
End Function

结果如下图5所示。

图5

注：本文整理自colinlegg.wordpress.com，供有兴趣的朋友学习参考。

vba 编程算法

0 人点赞