排名，请求高手帮忙谢谢！

909459520

老是用排序汇总不方便，能用VBA解决这个统计最好不过，多谢帮忙!

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Range([w3], Cells(Rows.Count, "aa").End(3)).Offset(1).ClearContents
   
5.     For j = 4 To Cells(Rows.Count, "h").End(3).Row
   
6.         If Not d.exists(Cells(j, 8).Value & "") Then
   
7.             Set d(Cells(j, 8).Value & "") = Cells(j, "e").Resize(1, 5)
   
8.         Else
   
9.             Set d(Cells(j, 8).Value & "") = Union(d(Cells(j, 8).Value & ""), Cells(j, "e").Resize(1, 5))
   
10.         End If
    
11.     Next j
    
12. 
    
13.     For Each rn In Array("3", "4", "9", "2")
    
14.         If d.exists(rn) Then
    
15.             d(rn).Copy Cells(Rows.Count, "w").End(3).Offset(1)
    
16.         End If
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

liulang0808

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

909459520

liulang0808 发表于 2018-7-18 09:11
附件内容供参考。。。。。。

先谢谢老师好快，只是不好意思我把条件写错了应该是相同工号越多越往前排(别的没变化)。

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, "aa").End(3)).Offset(1).ClearContents
   
6.     For Each rn In Array("3", "4", "9", "2")
   
7.         dn(rn) = 0
   
8.     Next
   
9.    
   
10.     For j = 4 To Cells(Rows.Count, "h").End(3).Row
    
11.         If dn.exists(Cells(j, 8).Value & "") Then
    
12.             If Not d.exists(Cells(j, 8).Value & "") Then
    
13.                 Set d(Cells(j, 8).Value & "") = Cells(j, "e").Resize(1, 5)
    
14.             Else
    
15.                 Set d(Cells(j, 8).Value & "") = Union(d(Cells(j, 8).Value & ""), Cells(j, "e").Resize(1, 5))
    
16.             End If
    
17.             dn(Cells(j, 8).Value & "") = dn(Cells(j, 8).Value & "") + 1
    
18.         End If
    
19.     Next j
    
20. l1:
    
21.     If dn.Count <> 0 Then
    
22.         mx = WorksheetFunction.Large(dn.items, 1)
    
23.         For j = 0 To d.Count - 1
    
24.             If dn.items()(j) = mx Then
    
25.                 rn = dn.keys()(j)
    
26.                 If d.exists(rn) Then
    
27.                     d(rn).Copy Cells(Rows.Count, "w").End(3).Offset(1)
    
28.                 End If
    
29.                 dn.Remove rn
    
30.                 Exit For
    
31.             End If
    
32.         Next
    
33.         GoTo l1
    
34.     End If
    
35. 
    
36.     Application.ScreenUpdating = True
    
37. End Sub

复制代码

liulang0808

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

909459520

liulang0808 发表于 2018-7-18 10:34
附件内容供参考。。。。。。

谢谢老师！！