[已解决]VBA筛选前三名

zss7758258

筛选前三名.zip (21.9 KB, 下载次数: 9)

2015-2-8 15:21 上传

点击文件名下载附件
请老师标注，如果想修改成为前N名，应该修改哪里的代码，谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-8 16:19

1. Sub Macro1()
   
2. Dim arr, ar, d, m%, i&, j%, k%, l%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. n = Range("o65536").End(xlUp).Row
   
5. [u:ae].NumberFormatLocal = "@"
   
6. For m = 11 To 15 Step 4
   
7.     ll = IIf(m = 11, 4, 2) '频率在数组中的列
   
8.     arr = Cells(1, m).Resize(n, 5)
   
9.     ReDim ar(1 To UBound(arr), 1 To UBound(arr, 2))
   
10.     For i = 2 To UBound(arr)
    
11.         If Not d.exists(arr(i, ll)) Then
    
12.             d(arr(i, ll)) = i
    
13.         Else
    
14.             d(arr(i, ll)) = d(arr(i, ll)) & "," & i
    
15.         End If
    
16.     Next
    
17.     s = 0
    
18.     For j = 1 To 3 '前3名
    
19.         x = Application.Large(d.keys, j)
    
20.         y = Split(d(x), ",")
    
21.         For k = 0 To UBound(y)
    
22.             s = s + 1
    
23.             For l = 1 To UBound(arr, 2)
    
24.                 ar(s, l) = arr(y(k), l)
    
25.             Next
    
26.         Next
    
27.     Next
    
28.     lie = IIf(m = 11, 21, 27)
    
29.     Cells(1, m).Resize(1, 5).Copy Cells(1, lie)
    
30.     Cells(2, lie).Resize(s, UBound(ar, 2)) = ar
    
31.     d.RemoveAll
    
32. Next
    
33. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, ar, d, m%, i&, j%, k%, l%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. n = Range("o65536").End(xlUp).Row
   
5. [u:ae].NumberFormatLocal = "@"
   
6. For m = 11 To 15 Step 4
   
7.     ll = IIf(m = 11, 4, 2) '频率在数组中的列
   
8.     arr = Cells(1, m).Resize(n, 5)
   
9.     ReDim ar(1 To UBound(arr), 1 To UBound(arr, 2))
   
10.     For i = 2 To UBound(arr)
    
11.         If Not d.exists(arr(i, ll)) Then
    
12.             d(arr(i, ll)) = i
    
13.         Else
    
14.             d(arr(i, ll)) = d(arr(i, ll)) & "," & i
    
15.         End If
    
16.     Next
    
17.     s = 0
    
18.     For j = 1 To 3 '前3名
    
19.         x = Application.Large(d.keys, j)
    
20.         y = Split(d(x), ",")
    
21.         For k = 0 To UBound(y)
    
22.             s = s + 1
    
23.             For l = 1 To UBound(arr, 2)
    
24.                 ar(s, l) = arr(y(k), l)
    
25.             Next
    
26.         Next
    
27.     Next
    
28.     lie = IIf(m = 11, 21, 27)
    
29.     Cells(1, m).Resize(1, 5).Copy Cells(1, lie)
    
30.     Cells(2, lie).Resize(s, UBound(ar, 2)) = ar
    
31.     d.RemoveAll
    
32. Next
    
33. End Sub

复制代码