提取前三个最大值及对应项

缔造者

要求：
分别提取B2：H14区域的前三个最大值及对应的小组，结果用逗号连接。

参见附件：

成本1.rar (6.88 KB, 下载次数: 13)

2016-8-29 18:43 上传

点击文件名下载附件

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
   
    Set d = CreateObject("scripting.dictionary")
    For m = 2 To 8
        arr = Range(Cells(1, m), Cells(14, m))
        d.RemoveAll
        For j = 1 To 3
            a = WorksheetFunction.Large(arr, j)
            For i = 2 To UBound(arr)
                If arr(i, 1) = a Then
                    d(Cells(i, 1) & "," & a) = ""
                End If
            Next i
        Next j
        Cells(2, m + 10).Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    Next m
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考，，，，

缔造者

liulang0808 发表于 2016-8-29 19:33
附件内容供参考，，，，

OK，感谢帮助！

hlly888

1. Sub yy() 'hlly888
   
2. Range("L2:r65536").ClearContents
   
3. Application.ScreenUpdating = False
   
4. Dim arr, brr(), i&, j%, x&, s&, g%, ss&
   
5. x = Cells(Rows.Count, 1).End(xlUp).Row
   
6. arr = Range("a2:h" & x)
   
7. ReDim brr(1 To UBound(arr), 1 To 10)
   
8. 
   
9.     For j = 2 To UBound(arr, 2)
   
10.         s = 0
    
11.         g = WorksheetFunction.Large(Range(Cells(2, j), Cells(x, j)), 3)
    
12.         For i = 1 To UBound(arr)
    
13.             If arr(i, j) >= g Then
    
14.                s = s + 1
    
15.                brr(s, j - 1) = arr(i, 1) & "," & arr(i, j)
    
16.             End If
    
17.         Next
    
18.         If s > ss Then ss = s
    
19.     Next
    
20.    
    
21. [L2].Resize(ss, 7) = brr
    
22. Application.ScreenUpdating = True
    
23. End Sub

复制代码

hlly888

成本2.zip (12.31 KB, 下载次数: 23)

2016-8-30 13:15 上传

点击文件名下载附件

缔造者

hlly888 发表于 2016-8-30 13:15

谢谢！OK，感谢帮助！

blackttea1

学习啦，谢谢