求助: excel分区多条件排名

qlmgu

1016373263 发表于 2021-1-23 17:22
把我的代码中的application.large换成application.small

学习了，非常感谢：不但有了逆向排序程序，还学习了一个语句。再次感谢。

1016373263

qlmgu 发表于 2021-1-23 20:29
学习了，非常感谢：不但有了逆向排序程序，还学习了一个语句。再次感谢。

花花0的突破

qlmgu

1016373263 发表于 2021-1-23 21:52
花花0的突破

老师的鼓励，再次感谢。

shi353

Sub tt1()
Dim A()
Set d = CreateObject("scripting.dictionary")
arr = [A3].CurrentRegion
For i = 2 To UBound(arr)
    C1 = arr(i, 4) = "否": C2 = d.exists(arr(i, 3))
    If C1 And C2 Then
        A = d(arr(i, 3)): m = UBound(A)
        m = m + 1
        ReDim Preserve A(1 To m)
        A(m) = arr(i, 5)
        d(arr(i, 3)) = A
    ElseIf C1 And Not C2 Then
        ReDim A(1 To 1): A(1) = arr(i, 5)
        d(arr(i, 3)) = A
    End If
Next
'-----------------------------
Set B = Range([A4], [A4].End(4))
For i = 1 To B.Cells.Count
    x1 = "": x2 = ""
    Set s = B.Cells(i)
    C3 = s.Offset(, 3) = "否"
    tt = s.Offset(, 2): t1 = d(tt): t2 = d(tt)
    BubbleSortDesc t1
    BubbleSortASC t2
    x1 = s.Offset(, 4)
    '------------------------------------
    For j = 1 To UBound(t1): If x1 = t1(j) Then x2 = j: Exit For
    Next
    If C3 And Len(x2) > 0 Then s.Offset(, 6) = x2
    '------------------------------------
    x2 = ""
    For j = 1 To UBound(t2): If x1 = t2(j) Then x2 = j: Exit For
    Next
    If C3 And Len(x2) > 0 Then s.Offset(, 7) = x2
    '------------------------------------
Next
End Sub


Sub BubbleSortASC(list)   '1D array sort Asc  sub sort 1D array
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim i As Long, j As Long
    Dim Temp As Long
    First = LBound(list)
    Last = UBound(list)
    For i = First To Last - 1
        For j = i + 1 To Last
            If list(i) > list(j) Then
                Temp = list(j)
                list(j) = list(i)
                list(i) = Temp
            End If
        Next j
    Next i
End Sub

Sub BubbleSortDesc(list)   '1D array sort Desc  sub sort 1D array
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim i As Long, j As Long
    Dim Temp As Long
    First = LBound(list)
    Last = UBound(list)
    For i = First To Last - 1
        For j = i + 1 To Last
            If list(i) < list(j) Then
                Temp = list(j)
                list(j) = list(i)
                list(i) = Temp
            End If
        Next j
    Next i
End Sub

qlmgu

shi353 发表于 2021-1-24 09:34
Sub tt1()
Dim A()
Set d = CreateObject("scripting.dictionary")

感谢shi353老师编写了新思路程序：同时可以降序和升序排名，有极大的方便之处。


我想把原来的数据放在A1开始（见下图），但是由于您的程序比较复杂，我试验多次也无法准确修改程序，修改了程序就报错。能否冒昧打扰老师帮忙修改下呢？无论如何都再次感谢您。

shi353

表格基準點變成A3變成A1 資料起始格由A4變成A2
就修正'arr = [A3].CurrentRegion 成  arr = [A1].CurrentRegion
修正'Set B = Range([A4], [A4].End(4)) 成 Set B = Range([A2], [A2].End(4))
應該很容易改的!
其他都沒變!
[A2].end(4)是代表A2儲存格範圍向下擴展到沒字串處空白處的意思

qlmgu

shi353 发表于 2021-1-24 21:11
表格基準點變成A3變成A1 資料起始格由A4變成A2
就修正'arr = [A3].CurrentRegion 成  arr = [A1].CurrentR ...

非常感谢shi353老师为我做出的解释和再次编辑了程序。
我下载了您这个修改过的程序，出现了报错的提示，见下图：






也许是我的操作出了问题。还想请老师查看下。
多谢再三。

qlmgu

shi353 发表于 2021-1-24 21:11
表格基準點變成A3變成A1 資料起始格由A4變成A2
就修正'arr = [A3].CurrentRegion 成  arr = [A1].CurrentR ...

问题解决了，谢谢老师。可能是传输时漏了一个“否”字。数据调整到A1，按您说的修改后，程序运行正常。再次感谢shi353老师