[已解决]怎样统计姓名重复次数？谢谢

小雨饰品

怎样用VBA统计姓名重复次数？
不好意思：现补充我没有讲清楚的一个注意点：我要统计连续出现的次数，当间隔出现时，就重新统计出现次数。请您再帮助看看看！
从新上传一个附件

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-7-21 16:22

小雨饰品 发表于 2012-7-21 15:26
谢谢您的出手，不好意思，我没有将其中一个小问题讲清楚：我要统计连续出现的次数，当间隔出现时，就重 ...

1. Sub test()
   
2.     Dim i As Long, j As Long
   
3.     Dim arr, brr()
   
4.     arr = Range("c4:c" & Range("c65536").End(xlUp).Row)
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     j = 1
   
7.     For i = UBound(arr) To 1 Step -1
   
8.         If i = 1 Then brr(i, 1) = j: Exit For
   
9.         If arr(i, 1) = arr(i - 1, 1) Then
   
10.             j = j + 1
    
11.         Else
    
12.             brr(i, 1) = j
    
13.             j = 1
    
14.         End If
    
15.     Next
    
16.     Range("d4:d65536").ClearContents
    
17.     Range("d4").Resize(UBound(brr), 1) = brr
    
18. End Sub

复制代码

跳转到最佳答案楼层

hrpotter

1. Sub test()
   
2.     Dim i As Long, j As Long
   
3.     Dim arr, brr()
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("c4:c" & Range("c65536").End(xlUp).Row)
   
7.     ReDim brr(1 To UBound(arr), 1 To 1)
   
8.     For i = 1 To UBound(arr)
   
9.         If d.exists(arr(i, 1)) Then
   
10.             j = d(arr(i, 1))
    
11.             brr(j, 1) = brr(j, 1) + 1
    
12.         Else
    
13.             d(arr(i, 1)) = i
    
14.             brr(i, 1) = 1
    
15.         End If
    
16.     Next
    
17.     Range("d4:d65536").ClearContents
    
18.     Range("d4").Resize(UBound(brr), 1) = brr
    
19. End Sub

复制代码

hhl1984

表.rar (31.3 KB, 下载次数: 33)

2012-7-21 14:51 上传

点击文件名下载附件 水平有限，只能这样，不知道能不能帮的上忙

小雨饰品

hrpotter 发表于 2012-7-21 14:46

谢谢您的出手，不好意思，我没有将其中一个小问题讲清楚：我要统计连续出现的次数，当间隔出现时，就重新统计出现次数。请您再帮助看看看！

小雨饰品

hhl1984 发表于 2012-7-21 14:51
水平有限，只能这样，不知道能不能帮的上忙

谢谢您的出手，不好意思，我没有将其中一个小问题讲清楚：我要统计连续出现的次数，当间隔出现时，就重新统计出现次数。请您再帮助看看看！

hrpotter

小雨饰品 发表于 2012-7-21 15:26
谢谢您的出手，不好意思，我没有将其中一个小问题讲清楚：我要统计连续出现的次数，当间隔出现时，就重 ...

1. Sub test()
   
2.     Dim i As Long, j As Long
   
3.     Dim arr, brr()
   
4.     arr = Range("c4:c" & Range("c65536").End(xlUp).Row)
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     j = 1
   
7.     For i = UBound(arr) To 1 Step -1
   
8.         If i = 1 Then brr(i, 1) = j: Exit For
   
9.         If arr(i, 1) = arr(i - 1, 1) Then
   
10.             j = j + 1
    
11.         Else
    
12.             brr(i, 1) = j
    
13.             j = 1
    
14.         End If
    
15.     Next
    
16.     Range("d4:d65536").ClearContents
    
17.     Range("d4").Resize(UBound(brr), 1) = brr
    
18. End Sub

复制代码

小雨饰品

hrpotter 发表于 2012-7-21 16:22

完全达到我预期效果，且运行速度很快。
非常感谢您的帮助。这下我可节省了不少时间。

lzfexcel

厉害，不过我现在还是看不懂数组。