请求用VBA统计指定区域人名出现的重复次数

fzh2618182

有时在工作中会用到“统计指定区域人名出现的重复次数”，请各位大师帮忙写一个代码。
要求：1、统计指定区域（A1：L51）人名出现的次数，分别在O列和P列中显示出来。
         2、最好对代码有具体的说明，以便于我学习和领悟。
         3、假如要改变指定区域的范围，应改变代码中哪些部分？

清风竹-

1. Sub 人名出现次数()
   
2. Dim i&, j&, Arr
   
3. Dim d, k, t
   
4. Columns("O:P").ClearContents
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Arr = Sheet1.Range("a1:l51")
   
7. For i = 1 To UBound(Arr)
   
8.     For j = 1 To UBound(Arr, 2)
   
9.        If Arr(i, j) <> "" Then d(Arr(i, j)) = d(Arr(i, j)) + 1
   
10.     Next
    
11. Next
    
12. k = d.keys
    
13. t = d.items
    
14. [o2].Resize(d.Count, 1) = Application.Transpose(k)
    
15. [p2].Resize(d.Count, 1) = Application.Transpose(t)
    
16. [o1].Resize(1, 2) = Array("姓名", "次数")
    
17. Set d = Nothing
    
18. End Sub

复制代码

清风竹-

请看附件。

fzh2618182

谢谢清风竹老师的热心帮助和指导！代码好使，速度也快，今天早上我把它移植到Excel2010中也行。我也曾借用过其他的代码，但是它把区域内的空格也作为一个人名统计进去了，而你这个代码是我最称心的。再次感谢大师！

零度夏点

厉害，作为VBA新手表示还有些看不懂，慢慢学习中，谢谢老师

xyc67012

这个可以用函数实现的，何必要编码啊！

秃头的大叔

Sub 统计区域不重复值()
t = Timer
Range("n1:p3000").Clear '清除原来数据
Dim arr1(1 To 3000), arr2(1 To 3000) '数组最大值3000视所有名字个数而定，只能大不能小，要不数组空间不够
a = Cells(1, Columns.Count).End(xlToLeft).Column '查找第一行所用单元格的列数
b = Cells(Rows.Count, 1).End(xlUp).Row '查找第一列所用单元格的行数,这两句是定位右下角单元格，相当于动态引用，表格大小随便变动都可以找到所用区域
Cells(1, a + 3) = "姓名" '空两列赋值
Cells(1, a + 4) = "次数"
arr = Range(Cells(1, 1), Cells(b, a)) '区域值赋给数组arr
For Each i In arr '遍历区域中的单元格，并把不重复的值存到数组arr1中
    For j = 1 To UBound(arr1) 'UBound(arr1)是计算数组arr1的最大值也就是3000
        If i = arr1(j) Then '如果单元格i等于数组arr1（j）那么循环下个单元格，说明数组arr1中已经存在一个相同的单元格也就是名字已经存在
            GoTo 100 '跳转语句，直接循环判断下个单元格
        End If
    Next j
    k = k + 1 '计数的目的是统计不重复名字的个数，也就是数组arr1的大小
       arr1(k) = i
100:
Next
[o2].Resize(k) = Application.Transpose(arr1) '以O2单元格为准，向下扩展k行，并把数组arr1（存储不重复名字的数组）写入这个区域
'                                             Application.Transpose把数组转换成一维
'统计重复次数，思路是遍历所有单元格，当它与数组arr1相同时计数，也就是重复的次数
For a1 = 1 To UBound(arr1)
    For Each i In arr '遍历区域
        If i = arr1(a1) Then '遍历数组arr1，此时的数组arr1是有前面筛选出来的不重复名字组成
        b1 = b1 + 1 '有相等的计数，单元格循环一遍有几个重复就记几次
        End If
    Next
    a2 = a2 + 1 '计数，因为没有定义a2，所以a2从零开始，方便下面将b1的值写入数组arr2
    arr2(a2) = b1 'b1值写入数组arr2
    b1 = 0 'b1归零，下次循环判断下个单元格的值时候b1就会累加，最后的出来的b1是一个值，也就是所有重复名字的次数，而不是我们要的数组
Next
[p2].Resize(k) = Application.Transpose(arr2) '数组写入
MsgBox "运行所需时间是：" & Format(Timer - t, "0.00") & "S" '计时器，计算程序运行所需时间
End Sub

Ronaldo09

论坛新人 只为学习学习