二维数组排序，可与range.sort媲美

时光鸟

Zamyi 发表于 2012-5-8 16:19
附件《多Key二维数组排序.rar》工作表“源码"中.

哎？我下载 打开后，怎么源码 里面是空的

Zamyi

时光鸟 发表于 2012-12-19 16:04
哎？我下载 打开后，怎么源码 里面是空的

多Key二维数组排序.rar _源码_包中.

高度保密

运行出错
这句：Z.ZSort R, a, 3, 1, 2, 0, 4, 0, 5, 0, 6, 0
无法继续，不知什么原因？

Zamyi

高度保密 发表于 2012-12-23 19:13
运行出错
这句：Z.ZSort R, a, 3, 1, 2, 0, 4, 0, 5, 0, 6, 0
无法继续，不知什么原因？

那不用封装,直接用源码.

VBA万岁

香川群子 发表于 2012-2-2 22:41
http://club.excelhome.net/thread-766196-1-1.html

我在这个帖子中，也有过尝试。

香川君，我想想你这段代码应用于多列列表框排序。结果出现以下错误：

VBA万岁

VBA万岁 发表于 2014-4-18 14:38
香川君，我想想你这段代码应用于多列列表框排序。结果出现以下错误：

稍做修改后，又出现以下错误：

VBA万岁

VBA万岁 发表于 2014-4-18 14:40
稍做修改后，又出现以下错误：

不知为何，烦请指点一二好吗？谢谢！附件如下：
多列列表框筛选排序.rar (23.81 KB, 下载次数: 43)

2014-4-18 14:41 上传

点击文件名下载附件

VBA万岁

VBA万岁 发表于 2014-4-18 14:42
不知为何，烦请指点一二好吗？谢谢！附件如下：

在其他帖子里搜索了一段代码，该问题终于解决，代码如下：
'通用数组排序 - 自定义函数Array_Sort（支持二维或一维）---by 泓()
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

VBA万岁

VBA万岁 发表于 2014-4-18 16:34
在其他帖子里搜索了一段代码，该问题终于解决，代码如下：
'通用数组排序 - 自定义函数Array_Sort（支持 ...

窗体代码如下：
Private Sub UserForm_Initialize()
    Dim arr, arr1, arr2, arr3, arr4, arr5, r%
    r = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
    arr = Range("A1").CurrentRegion
    arr1 = Range("A1:A" & r)
    arr2 = Range("B1:B" & r)
    arr3 = Range("C1:C" & r)
    arr4 = Range("D1:D" & r)
    arr5 = Range("E1:E" & r)
    ListBox1.List = arr
    ComboBox1.List = arr1
    ComboBox2.List = arr2
    ComboBox3.List = arr3
    ComboBox4.List = arr4
    ComboBox5.List = arr5
End Sub

Private Sub 筛选()
    On Error Resume Next
    Dim arr, brr(), i&, j&, m&, f(1 To 5) As Boolean, temp$(1 To 5), ok As Boolean
    For i = 1 To 5
        If Me.Controls("ComboBox" & i).Value <> "" Then
            f(i) = True
            temp(i) = Me.Controls("ComboBox" & i).Text
            ok = True
        End If
    Next
    If Not ok Then Exit Sub
    arr = ListBox1.List
    ReDim brr(0 To UBound(arr), 1 To 5)
    For i = 0 To UBound(arr)
        If ((f(1) And arr(i, 0) = temp(1)) Or Not f(1)) _
            And ((f(2) And arr(i, 1) = temp(2)) Or Not f(2)) _
            And ((f(3) And arr(i, 2) = temp(3)) Or Not f(3)) _
            And ((f(4) And arr(i, 3) = temp(4)) Or Not f(4)) _
            And ((f(5) And arr(i, 4) = temp(5)) Or Not f(5)) Then
            m = m + 1
            For j = 1 To 5
                brr(m - 1, j) = arr(i, j - 1)
            Next
        End If
    Next
    If m > 0 Then
        ListBox1.List = brr
    Else
        ListBox1.Clear
    End If
End Sub

Private Sub ComboBox1_Change()
Dim arr
arr = Range("A1").CurrentRegion
    If ComboBox1.Value = "" Then ListBox1.List = arr
    筛选
End Sub

Private Sub ComboBox2_Change()
Dim arr
arr = Range("A1").CurrentRegion
    If ComboBox2.Value = "" Then ListBox1.List = arr
    筛选
End Sub

Private Sub ComboBox3_Change()
Dim arr
arr = Range("A1").CurrentRegion
    If ComboBox3.Value = "" Then ListBox1.List = arr
    筛选
End Sub

Private Sub ComboBox4_Change()
Dim arr
arr = Range("A1").CurrentRegion
    If ComboBox4.Value = "" Then ListBox1.List = arr
    筛选
End Sub

Private Sub ComboBox5_Change()
Dim arr
arr = Range("A1").CurrentRegion
    If ComboBox5.Value = "" Then ListBox1.List = arr
    筛选
End Sub

Private Sub CommandButton1_Click()
Dim arr
    arr = ListBox1.List
    arr = Array_Sort(arr, 1, 2)
    ListBox1.List = arr
End Sub

VBA万岁

VBA万岁 发表于 2014-4-18 16:35
窗体代码如下：
Private Sub UserForm_Initialize()
    Dim arr, arr1, arr2, arr3, arr4, arr5, r%

截图如下：
排序前：



排序后：