提取不重复值及对应的第二个最大值

缔造者

jsxjd 发表于 2013-10-24 18:02
F2、G2公式，下拉：

谢谢帮助！
我这个是要求用VBA作，因为这些数据只是程序的一部分。

山菊花

删去红色那一行：
Sub tiqu()
    Dim ds, nRow%, n%, m%, Arr(), Brr()
    Set ds = CreateObject("scripting.dictionary") '定义字典
    nRow = Range("a65536").End(xlUp).Row
    Arr = Range("a2:b" & nRow).Value
    ReDim Brr(1 To nRow, 1 To 3)
    For i = 1 To nRow - 1
        n = ds(Arr(i, 1))
        If n = 0 Then
            m = m + 1
            n = m
            ds(Arr(i, 1)) = m
            Brr(m, 1) = Arr(i, 1)
'            Brr(m, 3) = Arr(i, 2)        
        End If
        If Arr(i, 2) >= Brr(n, 3) Then
            Brr(n, 2) = Brr(n, 3)
            Brr(n, 3) = Arr(i, 2)
        ElseIf Arr(i, 2) > Brr(n, 2) Then
            Brr(n, 2) = Arr(i, 2)        
　　End If
    Next
    Range("f2:g" & nRow).Value = Brr
End Sub

yangyangzhifeng

试试看

1. Sub test()
   
2.     Dim d, i&, ar, t, br(), r
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ar = Sheet1.Range("a1").CurrentRegion
   
5.     ReDim br(1 To UBound(ar), 1 To 3)
   
6.     For i = 2 To UBound(ar)
   
7.         r = d(Trim(ar(i, 1)))
   
8.         If r = "" Then
   
9.             r = d.count: d(Trim(ar(i, 1))) = r
   
10.             br(r, 1) = ar(i, 1)
    
11.             br(r, 2) = ar(i, 2)
    
12.         Else
    
13.             If br(r, 3) = "" Then
    
14.                 br(r, 3) = ar(i, 2)
    
15.                 If br(r, 2) > br(r, 3) Then
    
16.                     t = br(r, 2): br(r, 2) = br(r, 3): br(r, 3) = t
    
17.                 End If
    
18.             Else
    
19.                 If ar(i, 2) > br(r, 3) Then
    
20.                     br(r, 2) = br(r, 3): br(r, 3) = ar(i, 2)
    
21.                 ElseIf ar(i, 2) > br(r, 2) Then
    
22.                     br(r, 2) = ar(i, 2)
    
23.                 End If
    
24.             End If
    
25.         End If
    
26.     Next
    
27.     [h2].Resize(d.count, 2) = br
    
28. End Sub
    

复制代码

缔造者

yangyangzhifeng 发表于 2013-10-24 21:01
试试看

正确！谢谢帮助！
数据来回替换时，感觉绕的晕晕的（哈哈，我的脑筋转弯慢）。
再次表示感谢！谢谢您！！

缔造者

山菊花 发表于 2013-10-24 20:24
删去红色那一行：
Sub tiqu()
    Dim ds, nRow%, n%, m%, Arr(), Brr()

谢谢版主！程序个别有错（具体原因，说不清楚）！
欢迎版主，继续为广大菜鸟提供优质的帮助，再次表示感谢！

山菊花

缔造者 发表于 2013-10-25 15:05
谢谢版主！程序个别有错（具体原因，说不清楚）！
欢迎版主，继续为广大菜鸟提供优质的帮助，再次表示 ...

如果姓名没有重复记录，最后结果会是空白，那行红色代码本是为解决这个问题而写的。

hlly888

第二个最大值.rar (13.02 KB, 下载次数: 27)

2013-10-25 18:32 上传

点击文件名下载附件

缔造者

山菊花 发表于 2013-10-25 18:00
如果姓名没有重复记录，最后结果会是空白，那行红色代码本是为解决这个问题而写的。

是的，存在此情况。

缔造者

hlly888 发表于 2013-10-25 18:32

不错，缺陷是不是24小时制（有文字）。欢迎参与，希望修改下！！
谢谢帮助！谢谢！！

hlly888

第二个最大值.rar (12.37 KB, 下载次数: 19)

2013-10-25 21:06 上传

点击文件名下载附件