请求高手帮忙谢谢！

909459520

按出现次数多少进行统计(请求高手用vba统计)多谢帮忙!

tudarong

这个可以使用字典进行快速去重，并同时统计重复项的次数工号和名字作为key,重复次数作为item

按出现次数多少进行统计.rar (30.1 KB, 下载次数: 7)

2018-7-15 07:06 上传

点击文件名下载附件

1. Sub test()
   
2.     Dim dic As Object, d As Object
   
3.     Dim i%, Arr, m%
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     m = Sheet2.Range("E65536").End(xlUp).Row
   
7.     Arr = Range("E4:F" & m)
   
8.     For i = 1 To UBound(Arr, 1)
   
9.         dic(Arr(i, 2)) = dic(Arr(i, 2)) + 1
   
10.     Next
    
11.     For i = 1 To UBound(Arr, 1)
    
12.         d(Arr(i, 1)) = d(Arr(i, 1)) + 1
    
13.     Next
    
14.     [X4].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
15.     [Y4].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
16.     [Z4].Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
17. End Sub

复制代码

tudarong

如有帮助，请评分

909459520

tudarong 发表于 2018-7-15 07:07
这个可以使用字典进行快速去重，并同时统计重复项的次数工号和名字作为key,重复次数作为item

好快了，谢谢！！

909459520

tudarong 发表于 2018-7-15 07:07
这个可以使用字典进行快速去重，并同时统计重复项的次数工号和名字作为key,重复次数作为item

请求高手再次帮忙能否做个排名谢谢！

tudarong

排名.rar (41.19 KB, 下载次数: 11)

2018-7-15 11:58 上传

点击文件名下载附件

已做好，请测试。

1. Sub test()
   
2.     Dim Arr
   
3.     Dim m%, i%, j%, n%
   
4.     m = [F65536].End(xlUp).Row
   
5.     Arr = Range("F4:H" & m)
   
6.     j = 4
   
7.     For i = 1 To UBound(Arr, 1)
   
8.         If Arr(i, 3) = 3 Then
   
9.             Cells(j, "x") = Arr(i, 1)
   
10.             Cells(j, 25) = Arr(i, 2)
    
11.             Cells(j, 26) = Arr(i, 3)
    
12.             j = j + 1
    
13.         End If
    
14.     Next
    
15.     n = [x65536].End(xlUp).Row + 1
    
16.     For i = 1 To UBound(Arr, 1)
    
17.         If Arr(i, 3) = 4 Then
    
18.             Cells(n, "x") = Arr(i, 1)
    
19.             Cells(n, 25) = Arr(i, 2)
    
20.             Cells(n, 26) = Arr(i, 3)
    
21.             n = n + 1
    
22.         End If
    
23.     Next
    
24.     n = [x65536].End(xlUp).Row + 1
    
25.     For i = 1 To UBound(Arr, 1)
    
26.         If Arr(i, 3) = 9 Then
    
27.             Cells(n, "x") = Arr(i, 1)
    
28.             Cells(n, 25) = Arr(i, 2)
    
29.             Cells(n, 26) = Arr(i, 3)
    
30.             n = n + 1
    
31.         End If
    
32.     Next
    
33. End Sub
    

复制代码

tudarong

如有用得上，请评分。

909459520

tudarong 发表于 2018-7-15 07:07
这个可以使用字典进行快速去重，并同时统计重复项的次数工号和名字作为key,重复次数作为item

感谢谢帮忙！

909459520

tudarong 发表于 2018-7-15 11:59
已做好，请测试。

谢谢您的解答！您完美的解答了我的问题！对于您及时的帮助，特此向您表示衷心的感谢！如果您有时间能否再次帮忙统计个时间相同数，再次谢谢您！

tudarong

相同数.rar (589.4 KB, 下载次数: 3)

2018-7-15 21:57 上传

点击文件名下载附件

已统计完成，请测试。

1. Sub test()
   
2.     Dim dic As Object
   
3.     Dim m%, Arr, i%, j%
   
4.     Application.ScreenUpdating = False
   
5.     m = [Y65536].End(xlUp).Row
   
6.     Arr = Range("Y5:Y" & m)
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     For i = 1 To UBound(Arr, 1)
   
9.         dic(Arr(i, 1)) = dic(Arr(i, 1)) + 1
   
10.     Next
    
11.     [T5].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
12.     [U5].Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
13.       
    
14.     j = [U65536].End(xlUp).Row
    
15.     Range("T4:U" & j).Select
    
16.     ActiveWorkbook.Worksheets("Sheet1 (2)").Sort.SortFields.Clear
    
17.     ActiveWorkbook.Worksheets("Sheet1 (2)").Sort.SortFields.Add Key:=Range( _
    
18.         "U5:U102"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    
19.         xlSortNormal
    
20.     With ActiveWorkbook.Worksheets("Sheet1 (2)").Sort
    
21.         .SetRange Range("T4:U102")
    
22.         .Header = xlYes
    
23.         .MatchCase = False
    
24.         .Orientation = xlTopToBottom
    
25.         .SortMethod = xlPinYin
    
26.         .Apply
    
27.     End With
    
28.     Range("T5:U5").Select
    
29.     Selection.Delete Shift:=xlUp
    
30.     Range("T4").Select
    
31.     Application.ScreenUpdating = True
    
32. End Sub

复制代码