VBA分段统计数字的次数

1、需求：

根据员工的年龄，分年龄段统计人数。

2、举例：

接着上一次的例子，得到了出生日期后，然后你又得到任务，需要分年龄段统计人数。

序号	年龄段‍	人数
1	20以下‍
2	20-35
3	35-45
4	45-55
5	55以上

算年龄用Year函数获取年份，用当前的年份减就可以了。

其实熟悉函数的话，这个用LOOKUP是非常合适的：

=LOOKUP(E2,{0,"20以下";20,"20-35";35,"35-45";45,"45-55";55,"55以上"})

然后再用数据透视表或者SUMIF等方法都可以。

3、代码实现

我们来看看用VBA如何完成这项工作，其实我们也是要实现一个类似LOOKUP的函数，LOOKUP的实现原理应该就是使用了二分法来查找，所谓二分法，从名字上大概就能猜到，它每次查找都能把数据量减半，大概原理如下：

二分法一次就能去掉一半的数据量，查找是非常高效的。100个数字，最多7次就可以找到所需要的数据，是以2为底数，计算数据个数的对数，1亿的数据量的话，最多是27次能找到需要的数据。当然它有一个重要的前提，数据源必须是排序的。

好了，知道了原理，我们用VBA代码来实现它：

'Arr    数据源，升序
'FindValue  要查找的数据
'找到Arr中刚好小于或等于它、并且下一个大于它的数据，返回下标
Function BinarySearch(arr() As Long, FindValue As Long) As Long
    Dim low As Long, high As Long
    Dim iMid As Long
    Dim iEnd As Long
    
    iEnd = UBound(arr)
    high = iEnd
    low = LBound(arr)
    
    Do While low <= high
        iMid = (high + low)  2
        If arr(iMid) = FindValue Then
            Exit Do
        ElseIf arr(iMid) < FindValue Then
            '小于的时候还要保证iMid+1是大于它的
            If iMid = iEnd Then
                Exit Do
            Else
                If arr(iMid + 1) > FindValue Then
                    Exit Do
                End If
            End If
            
            '没有退出，说明还要往后面继续查找
            low = iMid + 1
        Else
            high = iMid - 1
        End If
    Loop
    
    If low > high Then
        BinarySearch = -1
    Else
        BinarySearch = iMid
    End If
End Function

有了这个函数，我们看看如何使用它来分段统计人数，最简单的想法自然是根据返回的下标，在数据源基础上新生成一列年龄段的描述，再根据这个新列用字典对象来统计。

但是，既然函数能够返回年龄段的下标，其实我们直接用数组就可以来统计出现的次数了：

Enum RetCode
    ErrRT = -1
    SuccRT = 1
End Enum

Enum Pos
    RowStart = 2
    
    姓名 = 3
    年龄 = 5
    
    KeyCol = 姓名
    Cols = 年龄
End Enum

Type DataStruct
    Src() As Variant
    Rows As Long
    Cols As Long
    
    Result() As Variant
End Type

Sub vba_main()
    Dim d As DataStruct
    
    If RetCode.ErrRT = ReadSrc(d) Then Exit Sub
    If RetCode.ErrRT = GetResult(d) Then Exit Sub
End Sub

Private Function GetResult(d As DataStruct) As RetCode
    ReDim d.Result(1 To 5, 1 To 2) As Variant
    
    d.Result(1, 1) = "20以下"
    d.Result(2, 1) = "20-35"
    d.Result(3, 1) = "35-45"
    d.Result(4, 1) = "45-55"
    d.Result(5, 1) = "55以上"
    
    Dim arr(1 To 5) As Long
    arr(1) = 0
    arr(2) = 20
    arr(3) = 35
    arr(4) = 45
    arr(5) = 55
    
    Dim i As Long
    Dim prow As Long
    For i = Pos.RowStart To d.Rows
        prow = BinarySearch(arr, VBA.CLng(d.Src(i, Pos.年龄)))
        d.Result(prow, 2) = d.Result(prow, 2) + 1
    Next
    
    Range("A1").Offset(1, Pos.Cols + 1).Resize(5, 2).Value = d.Result
End Function

Private Function ReadSrc(d As DataStruct) As RetCode
    ReadSrc = ReadData(d.Src, d.Rows, Pos.Cols, Pos.KeyCol, Pos.RowStart)
End Function

Private Function ReadData(ByRef RetArr() As Variant, ByRef RetRow As Long, Cols As Long, KeyCol As Long, RowStart As Long) As RetCode
    ActiveSheet.AutoFilterMode = False
    RetRow = Cells(Cells.Rows.Count, KeyCol).End(xlUp).Row
    If RetRow < RowStart Then
        MsgBox "没有数据"
        ReadData = RetCode.ErrRT
        Exit Function
    End If
    RetArr = Cells(1, 1).Resize(RetRow, Cols).Value

    ReadData = RetCode.SuccRT
End Function

结果：

技巧：

这个问题其实还能有一个很好的技巧，我们观察需要统计的数据，很明显，数据是比较小的，不会超过100，而且又是数字，我们先记录1-100的数字对应的年龄段的下标，再判断年龄属于哪个区间段的时候，直接读取数组就可以了，省去了二分法查找，代码只需要改动GetResult：

Private Function GetResult(d As DataStruct) As RetCode
    ReDim d.Result(1 To 5, 1 To 2) As Variant
    
    d.Result(1, 1) = "20以下"
    d.Result(2, 1) = "20-35"
    d.Result(3, 1) = "35-45"
    d.Result(4, 1) = "45-55"
    d.Result(5, 1) = "55以上"
    
    Dim arr(1 To 6) As Long
    arr(1) = 0
    arr(2) = 20
    arr(3) = 35
    arr(4) = 45
    arr(5) = 55
    arr(6) = 101
    
    '技巧：利用1个数组来记录数字的下标
    Dim Interval(100) As Long
    Dim i As Long, j As Long
    For i = 1 To 5
        For j = arr(i) To arr(i + 1) - 1
            Interval(j) = i
        Next
    Next
    
    Dim prow As Long
    For i = Pos.RowStart To d.Rows
        '直接通过数组获取年龄段的下标
        prow = Interval(VBA.CLng(d.Src(i, Pos.年龄)))
        d.Result(prow, 2) = d.Result(prow, 2) + 1
    Next
    
    Range("A1").Offset(1, Pos.Cols + 1).Resize(5, 2).Value = d.Result
End Function

在数据量很大的情况，你会非常明显的感觉到这个技巧带来的速度提升。