使用字典对象快速统计重复姓名及出现次数

'我们惊叹字典处理重复数据的效率，实在是太快

'本示例用于统计去除重复值后的姓名及出现次数，喜欢就收下吧。

Sub test()

    Dim myr&, i&, arr

    Dim d, k, t

    '创建字典对象，使用后期绑定

    Set d = CreateObject('Scripting.Dictionary')

    

    '取Sheet1工作表第一列最后一个有值的行的行号

    myr = Sheets('Sheet1').Cells(Rows.Count, 1).End(xlUp).Row

    '将A1到D列与myr变量组成的单元格区域赋给数组

    arr = Sheets('Sheet1').Range('A1:D' & myr)

    '将单元格区域组成的二维数组装入字典

    '因姓名在A2往下的单元格中，故循环变量从2起

    For i = 2 To UBound(arr)

        d(arr(i, 1)) = d(arr(i, 1)) 1

    Next

'    如果只统计出现1次以上的姓名，可使用Remove方法把不重复的移出

'    For i = 2 To UBound(arr)

'        If d(arr(i, 1)) < 2 Then d.Remove arr(i, 1)

'    Next

    'k是一个一维数组，它包含的是字典d的所有关键字

    k = d.Keys

    't是一个一维数组，它包含的是字典d的所有条目

    t = d.Items

    '激活Sheet2工作表，输出结果

    Sheets('Sheet2').Activate

    '在A1单元格中输入姓名，在A2单元格中输入出现次数

    [A1].Resize(1, 2) = Array('姓名', '出现次数')

    '自A2单元格起向下输入不重复的姓名，用Transpose对一维数据进行转置

    [A2].Resize(d.Count, 1) = Application.Transpose(k)

    '自B2单元格起向下对应输入每个姓名出现的次数

    [B2].Resize(d.Count, 1) = Application.Transpose(t)

    Set d = Nothing

End Sub

清晰的代码如图：