将指定数据区域某列数据前30输入数组后排序输出

weiyingde

要求：将指定数据区域某列数据前30输入数组后，然后再用提供的自定义数组排序输出，代码如下：
Sub 将前30输入数组后排序输出()
Worksheets("前三十名").Range("A1").CurrentRegion.ClearContents
Dim arr, brr(), crr()
With Worksheets("期中考试")
r = .UsedRange.Rows.Count
c = .UsedRange.Columns.Count
c1 = .Range("a2").End(xlToRight).Column
arr = Array(Application.Transpose(.Range("A2:A" & r)), Application.Transpose(.Range("B2:B" & r)), Application.Transpose(.Range("F2:F" & r)), Application.Transpose(.Range("G2:G" & r)), _
             Application.Transpose(.Range("H2:H" & r)), Application.Transpose(.Range("I2:I" & r)))
arr = Application.Transpose(arr)
For i = 1 To UBound(arr)
    If arr(i, 4) <= 30 Then
        n = n + 1
        ReDim Preserve brr(1 To 6, 1 To n)
        For j = 1 To 6
            brr(j, n) = arr(i, j)
        Next
    End If
    If arr(i, 6) <= 30 Then
        m = m + 1
        ReDim Preserve crr(1 To 6, 1 To m)
        For k = 1 To 6
            crr(k, m) = arr(i, k)
        Next
    End If
Next
brr = Application.Transpose(brr)
crr = Application.Transpose(crr)
End With

brr = Array_Sort(brr, 4, 1) '这里出问题，不知怎样表达？

With Worksheets("前三十名")
     .Range("A1").Resize(n, 6) = brr
    ' .Range("G1").Resize(m, 6) = crr
End With
End Sub


Function Array_Sort(Array_&(), Key1&, Order&)    '(Array_[将要排序的数组], Key1[数组(y,x)中x，像表格中的哪一列作关键字], Order[=1,升序;<>1,降序])
    Dim t, x&, y&, i&, j&, k&, xx&, yy&, tt&, AD&
    For i = 1 To 60
        On Error Resume Next
        Err.Clear
        tt = UBound(Array_, i)
        If Err.Number = 9 Then AD = i - 1: Exit For    'AD,数组维数
    Next
    If AD = 2 Then
        If Not (Key1 >= LBound(Array_, 2) And Key1 <= UBound(Array_, 2)) Then Exit Function
    ElseIf AD = 1 Then
        Array_ = Application.Transpose(Array_)
        Key1 = 1
    Else
        Exit Function
    End If
    y = LBound(Array_, 1): x = LBound(Array_, 2)
    yy = UBound(Array_): xx = UBound(Array_, 2)
    If Order = 1 Then    '升序
        For i = y To yy - 1
            For j = i + 1 To yy
                If Array_(j, Key1) < Array_(i, Key1) Then    '冒泡排序法
                    For k = x To xx
                        t = Array_(j, k): Array_(j, k) = Array_(i, k): Array_(i, k) = t
                    Next
                End If
            Next
        Next
    Else    '降序
        For i = y To yy - 1
            For j = i + 1 To yy
                If Array_(j, Key1) > Array_(i, Key1) Then
                    For k = x To xx
                        t = Array_(j, k): Array_(j, k) = Array_(i, k): Array_(i, k) = t
                    Next
                End If
            Next
        Next
    End If
    If AD = 2 Then Array_Sort = Array_ Else Array_Sort = Application.Transpose(Array_)
End Function

weiyingde

在求大侠指点，在线等。先谢了

一把小刀闯天下

weiyingde 发表于 2018-12-2 16:30
在求大侠指点，在线等。先谢了

'冒个泡就可以了，数据量大改归并（你这对稳定性有要求）

Option Explicit

Sub test()
  Dim arr, i, j, pos
  arr = Sheets("期中考试").[a1].CurrentRegion.Offset(1).Value
  pos = Array(1, 2, 6, 7, 8, 9)
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, 9, 7, True)
  For i = 1 To 30
    For j = 0 To UBound(pos): arr(i, j + 1) = arr(i, pos(j)): Next
  Next
   Sheets("前三十名").[a1].Resize(30, UBound(pos) + 1) = arr
End Sub

Function bsort(arr, first, last, left, right, key, order)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) <= arr(j + 1, key) Xor order Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
  Next j, i
End Function

weiyingde

一把小刀闯天下 发表于 2018-12-2 19:17
'冒个泡就可以了，数据量大改归并（你这对稳定性有要求）

Option Explicit

谢谢你的答复。
谢谢！！
不过，我自己已经解决问题了。只在申明中动了一个小手术，便可以了。
Function Array_Sort(Array_&(), Key1&, Order&)   
……
End Function
把红色“&()”去掉就行了。
我不知道为什么要申明为“&()”这样的？

weiyingde

一把小刀闯天下 发表于 2018-12-2 19:17
'冒个泡就可以了，数据量大改归并（你这对稳定性有要求）

Option Explicit

这个解决思路，很简洁，很清晰，很好！！以后若有问题，多向你请教！！