需要大神、高手各显神通，提高速度。

时间的音符

我不会  溜了.

时间的音符

.........................
这个用自己修改的ArrayList应该行了吧.
我这次做的和之前做的绝对正确,
出错了就是你的电脑环境

pilyx

强大 这个厉害，我测试一下万行以上数据看看再。。谢谢您，忙了这么久。

pilyx

时间的音符 发表于 2020-1-27 22:19
.........................
这个用自己修改的ArrayList应该行了吧.
我这次做的和之前做的绝对正确,

太厉害，这个强大，完全看不懂。速度杠杠滴。这算法我得学10年以上。。。。。。

cui26896

用了山菊花版主的主程序，一把小刀闯天下的快速排序自定义函数，凑了一个，速度不到一秒种。
Book1.zip (103.86 KB, 下载次数: 6)

2020-1-28 07:59 上传

点击文件名下载附件

cui26896

上传附件要审核，先把代码附上
Sub test()
Dim mrow, mcol
Dim arr, i&, i2&, j&, pxarr, njarr, bjarr, bjbrr, bjstr, pxfs, k
tms = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
mrow = Cells(Rows.Count, 1).End(xlUp).Row
mcol = Cells(1, Columns.Count).End(xlToLeft).Column
arr = Range("a1").Resize(mrow, mcol).Value
ReDim njarr(1 To UBound(arr), 4 To UBound(arr, 2)), bjarr(1 To UBound(arr), 4 To UBound(arr, 2))
ReDim pxarr(2 To UBound(arr), 1 To 2)
For i = 4 To UBound(arr, 2)
ReDim bjbrr(1 To 100, 1 To 3)
  njarr(1, i) = arr(1, i) & "年级名次"
  bjarr(1, i) = arr(1, i) & "班级名次"
  
  For i2 = 2 To UBound(pxarr) '把要排序的分数列导入并编行号
    pxarr(i2, 1) = i2
    pxarr(i2, 2) = arr(i2, i)
  Next
  Call qsort(pxarr, 2, UBound(pxarr), 1, 2, 2)
  pxfs = 0
  For i2 = 2 To UBound(pxarr)
    If pxfs <> pxarr(i2, 2) Then
      pxfs = pxarr(i2, 2)
      k = i2 - 1
    End If
    njarr(pxarr(i2, 1), i) = k
    If left(arr(pxarr(i, 1), 3), 1) = "0" Then
      bjstr = Mid(arr(pxarr(i, 1), 3), 2, 1)
      Else
        bjstr = Mid(arr(pxarr(i, 1), 3), 1, 2)
    End If
    bjbrr(bjstr, 1) = bjbrr(bjstr, 1) + 1
    If bjbrr(bjstr, 2) <> pxfs Then
      bjbrr(bjstr, 2) = pxfs
      bjbrr(bjstr, 3) = bjbrr(bjstr, 1)
    End If
    bjarr(pxarr(i2, 1), i) = bjbrr(bjstr, 3)
  Next
Next
Range("x1").Resize(mrow, mcol - 3).Value = njarr
Range("ar1").Resize(mrow, mcol - 3).Value = bjarr
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "合成完毕！共用了" & Format(Timer - tms, "0.000秒")
End Sub

Function qsort(arr, first, last, left, right, key)
  Dim i As Long, j As Long, k As Long, x As String, t As String
  i = first: j = last: x = arr(Int((first + last) / 2), key)
  While i <= j
    While arr(i, key) > x: i = i + 1: Wend
    While x > arr(j, key): j = j - 1: Wend
    If i <= j Then
      For k = left To right
        t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
      Next
      i = i + 1: j = j - 1
    End If
  Wend
  If first < j Then qsort arr, first, j, left, right, key
  If i < last Then qsort arr, i, last, left, right, key
End Function

pilyx

cui26896 发表于 2020-1-28 08:15
上传附件要审核，先把代码附上
Sub test()
Dim mrow, mcol

我先测试一下，看看有没有bug，先感谢！

pilyx

cui26896 发表于 2020-1-28 08:15
上传附件要审核，先把代码附上
Sub test()
Dim mrow, mcol

哈哈 排错啦，出来数据都是错的。。。不过还是谢谢。

cui26896

小刀老师的快速排序稳定性有一定问题，他也曾强调过，看来还是只有沿处灰袍法师的混排稳定才有保障。
Sub test()
Dim mrow, mcol
Dim arr, i&, i2&, j&, pxarr, njarr, bjarr, bjbrr, bjstr, pxfs, k
tms = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
mrow = Cells(Rows.Count, 1).End(xlUp).Row
mcol = Cells(1, Columns.Count).End(xlToLeft).Column
arr = Range("a1").Resize(mrow, mcol).Value
ReDim njarr(1 To UBound(arr), 4 To UBound(arr, 2)), bjarr(1 To UBound(arr), 4 To UBound(arr, 2))
ReDim pxarr(2 To UBound(arr), 1 To 2)
For i = 4 To UBound(arr, 2)
ReDim bjbrr(1 To 100, 1 To 3)
  njarr(1, i) = arr(1, i) & "年级名次"
  bjarr(1, i) = arr(1, i) & "班级名次"
  
  For i2 = 2 To UBound(pxarr) '把要排序的分数列导入并编行号
    pxarr(i2, 1) = i2
    pxarr(i2, 2) = arr(i2, i)
  Next
  Call StartSort(pxarr, 2, UBound(arr))
  pxfs = 0
  For i2 = 2 To UBound(pxarr)
    If pxfs <> pxarr(i2, 2) Then
      pxfs = pxarr(i2, 2)
      k = i2 - 1
    End If
    njarr(pxarr(i2, 1), i) = k
    If left(arr(pxarr(i, 1), 3), 1) = "0" Then
      bjstr = Mid(arr(pxarr(i, 1), 3), 2, 1)
      Else
        bjstr = Mid(arr(pxarr(i, 1), 3), 1, 2)
    End If
    bjbrr(bjstr, 1) = bjbrr(bjstr, 1) + 1
    If bjbrr(bjstr, 2) <> pxfs Then
      bjbrr(bjstr, 2) = pxfs
      bjbrr(bjstr, 3) = bjbrr(bjstr, 1)
    End If
    bjarr(pxarr(i2, 1), i) = bjbrr(bjstr, 3)
  Next
Next
Range("x1").Resize(mrow, mcol - 3).Value = njarr
Range("ar1").Resize(mrow, mcol - 3).Value = bjarr
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "合成完毕！共用了" & Format(Timer - tms, "0.000秒")
End Sub
Sub StartSort(arr, l As Long, R As Long)
    Dim i As Long, j As Long
    Dim x As Date, Swap
    If R - l <= 16 Then
        For i = l To R
            x = i
            For j = i + 1 To R
                If arr(j, 2) > arr(x, 2) Then
                    x = j
                End If
            Next j
            
            If x > i Then
                For j = 1 To 2
                    Swap = arr(i, j)
                    arr(i, j) = arr(x, j)
                    arr(x, j) = Swap
                Next
            End If
        Next i
    Else
        x = arr((l + R) \ 2, 2)
        i = l
        j = R
        Do While i <= j
            Do While arr(i, 2) > x
                i = i + 1
            Loop
            
            Do While arr(j, 2) < x
                j = j - 1
            Loop
           
            If i <= j Then
                For j1 = 1 To 2
                    Swap = arr(i, j1)
                    arr(i, j1) = arr(j, j1)
                    arr(j, j1) = Swap
                Next
                i = i + 1
                j = j - 1
            End If
        Loop
        If (l < j) Then Call StartSort(arr, l, j)
        If (i < R) Then Call StartSort(arr, i, R)
    End If
End Sub
Book1.zip (101.67 KB, 下载次数: 2)

2020-1-28 18:36 上传

点击文件名下载附件

cui26896

又要审核，
Sub test()
Dim mrow, mcol
Dim arr, i&, i2&, j&, pxarr, njarr, bjarr, bjbrr, bjstr, pxfs, k
tms = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
mrow = Cells(Rows.Count, 1).End(xlUp).Row
mcol = Cells(1, Columns.Count).End(xlToLeft).Column
arr = Range("a1").Resize(mrow, mcol).Value
ReDim njarr(1 To UBound(arr), 4 To UBound(arr, 2)), bjarr(1 To UBound(arr), 4 To UBound(arr, 2))
ReDim pxarr(2 To UBound(arr), 1 To 2)
For i = 4 To UBound(arr, 2)
ReDim bjbrr(1 To 100, 1 To 3)
  njarr(1, i) = arr(1, i) & "年级名次"
  bjarr(1, i) = arr(1, i) & "班级名次"
  
  For i2 = 2 To UBound(pxarr) '把要排序的分数列导入并编行号
    pxarr(i2, 1) = i2
    pxarr(i2, 2) = arr(i2, i)
  Next
  Call StartSort(pxarr, 2, UBound(arr))
  pxfs = 0
  For i2 = 2 To UBound(pxarr)
    If pxfs <> pxarr(i2, 2) Then
      pxfs = pxarr(i2, 2)
      k = i2 - 1
    End If
    njarr(pxarr(i2, 1), i) = k
    If left(arr(pxarr(i, 1), 3), 1) = "0" Then
      bjstr = Mid(arr(pxarr(i, 1), 3), 2, 1)
      Else
        bjstr = Mid(arr(pxarr(i, 1), 3), 1, 2)
    End If
    bjbrr(bjstr, 1) = bjbrr(bjstr, 1) + 1
    If bjbrr(bjstr, 2) <> pxfs Then
      bjbrr(bjstr, 2) = pxfs
      bjbrr(bjstr, 3) = bjbrr(bjstr, 1)
    End If
    bjarr(pxarr(i2, 1), i) = bjbrr(bjstr, 3)
  Next
Next
Range("x1").Resize(mrow, mcol - 3).Value = njarr
Range("ar1").Resize(mrow, mcol - 3).Value = bjarr
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "合成完毕！共用了" & Format(Timer - tms, "0.000秒")
End Sub

Sub StartSort(arr, l As Long, R As Long)
    Dim i As Long, j As Long
    Dim x As Date, Swap
    If R - l <= 16 Then
        For i = l To R
            x = i
            For j = i + 1 To R
                If arr(j, 2) > arr(x, 2) Then
                    x = j
                End If
            Next j
            
            If x > i Then
                For j = 1 To 2
                    Swap = arr(i, j)
                    arr(i, j) = arr(x, j)
                    arr(x, j) = Swap
                Next
            End If
        Next i
    Else
        x = arr((l + R) \ 2, 2)
        i = l
        j = R
        Do While i <= j
            Do While arr(i, 2) > x
                i = i + 1
            Loop
            
            Do While arr(j, 2) < x
                j = j - 1
            Loop
           
            If i <= j Then
                For j1 = 1 To 2
                    Swap = arr(i, j1)
                    arr(i, j1) = arr(j, j1)
                    arr(j, j1) = Swap
                Next
                i = i + 1
                j = j - 1
            End If
        Loop

        If (l < j) Then Call StartSort(arr, l, j)
        If (i < R) Then Call StartSort(arr, i, R)
    End If
End Sub