另类的提取前N名，谢谢quqiyuan和ykcbf1100、usedrange、chxw68老师！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:i" & r)
   
9.         ReDim brr(1 To UBound(arr), 1 To 2)
   
10.         m = 0
    
11.         For i = 1 To UBound(arr)
    
12.             m = m + 1
    
13.             d(arr(i, 9)) = Empty
    
14.             If arr(i, 9) = 0 Or d.Count > 3 Or m > 20 Then
    
15.                 Exit For
    
16.             End If
    
17.             brr(m, 1) = arr(i, 2)
    
18.             brr(m, 2) = arr(i, 9)
    
19.         Next
    
20.         .Range("p2:q" & .Rows.Count).ClearContents
    
21.         .Range("p2").Resize(m, 2) = brr
    
22.     End With
    
23. End Sub
    

复制代码

chxw68

凑个热闹。

taller

lhj323323 发表于 2024-9-10 08:27
谢谢老师

但是运行后要报错

获取前三名的最小值时使用了工作表函数Unique，低版本不支持，可以使用字典获取

1. 
   
2. Sub test()
   
3.     Dim fso As Object, f, ff
   
4.     Dim myname$, P$
   
5.     'Dim sh As Workbook, wb As Workbook
   
6.     Dim sh, wb As Workbook
   
7.     Dim Arr2, arr, Brr()
   
8.     Dim myr%, i%, n%, iMax, iR
   
9.     Dim bs As String
   
10.     Application.ScreenUpdating = False
    
11.     With Sheet1
    
12.         arr = .[a1].CurrentRegion
    
13.     End With
    
14.     Dim objDic
    
15.     Set objDic = CreateObject("scripting.dictionary")
    
16.     For i = 1 To UBound(arr)
    
17.         objDic(arr(i, 9)) = ""
    
18.     Next
    
19.     iMax = Application.Large(objDic.Keys, 3)
    
20.    
    
21.     ReDim Brr(1 To UBound(arr), 1 To 3)
    
22.     For i = 2 To UBound(arr) '提取前3名
    
23.         If arr(i, 9) >= iMax Then
    
24.             iR = iR + 1
    
25.             If iR > 20 Then Exit For
    
26.             Brr(iR, 1) = arr(i, 2)
    
27.             Brr(iR, 2) = arr(i, 9)
    
28.         End If
    
29.     Next
    
30.     With Sheet1
    
31.         .[p1].Resize(iR, UBound(Brr, 2)) = Brr
    
32.     End With
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    
36. 
    

复制代码

lhj323323

taller 发表于 2024-9-10 09:30
获取前三名的最小值时使用了工作表函数Unique，低版本不支持，可以使用字典获取

谢谢老师！

lhj323323

chxw68 发表于 2024-9-10 08:49
凑个热闹。

谢谢chxw68老师！
测试成功
明日奉上鲜花。