请求高手帮忙；按工号姓名出现次数多少统计，谢谢！

909459520

请求高手帮忙；按工号姓名出现次数多少统计，谢谢！

liulang0808

楼主之前咨询的帖子
http://club.excelhome.net/thread-1425479-1-1.html
当时给了解决方法，楼主自己尝试解决下

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set dn = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Range([w3], Cells(Rows.Count, "ab").End(3)).Offset(1).ClearContents
   
6. 
   
7.    
   
8.     For j = 4 To Cells(Rows.Count, "h").End(3).Row
   
9.         If Len(Cells(j, 8).Value) <> 0 Then
   
10.             If Not d.exists(Cells(j, 6) & Cells(j, 7)) Then
    
11.                 Set d(Cells(j, 6) & Cells(j, 7)) = Cells(j, "e")
    
12.             Else
    
13.                 Set d(Cells(j, 6) & Cells(j, 7)) = Union(d(Cells(j, 6) & Cells(j, 7)), Cells(j, "e"))
    
14.             End If
    
15.             dn(Cells(j, 6) & Cells(j, 7)) = dn(Cells(j, 6) & Cells(j, 7)) + 1
    
16.         End If
    
17.     Next j
    
18.     a = 1
    
19. l1:
    
20.     If dn.Count <> 0 And a < 51 Then
    
21.         mx = WorksheetFunction.Large(dn.items, 1)
    
22.         For j = 0 To d.Count - 1
    
23.             If dn.items()(j) = mx Then
    
24.                 rn = dn.keys()(j)
    
25.                 If d.exists(rn) Then
    
26.                     r1 = Cells(Rows.Count, "x").End(3).Offset(1).Row
    
27.                     d(rn).Copy Cells(r1, "w")
    
28.                     d(rn).Offset(0, 1).Copy Cells(r1, "x")
    
29.                     d(rn).Offset(0, 2).Copy Cells(r1, "y")
    
30.                     d(rn).Offset(0, 3).Copy Cells(r1, "aa")
    
31.                     d(rn).Offset(0, 4).Copy Cells(r1, "ab")
    
32.                     
    
33.                     r2 = Cells(Rows.Count, "w").End(3).Row
    
34.                     Range(Cells(r1, "z"), Cells(r2, "z")).Value = dn(rn)
    
35.                 End If
    
36.                 dn.Remove rn
    
37.                 Exit For
    
38.             End If
    
39.         Next
    
40.         GoTo l1
    
41.     End If
    
42. 
    
43.     Application.ScreenUpdating = True
    
44. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

909459520

liulang0808 发表于 2018-7-19 08:44
附件内容供参考。。。。。。

对你的热心和耐心非常非常感谢！祝福好人一生平安。

mjzxlmg

测试附件：

取较多值(频率).rar (30.82 KB, 下载次数: 13)

2018-7-19 09:21 上传

点击文件名下载附件

909459520

mjzxlmg 发表于 2018-7-19 09:21
测试附件：

太棒了 要的就是这个效果 ，谢谢！