|
|
楼主 |
发表于 2020-7-17 10:51
|
显示全部楼层
本帖最后由 山中老人 于 2020-7-19 09:57 编辑
考虑到很多问题，完整的排序代码弄得很复杂，大家看看吧！排序过程中以行号(Index)为对象进行，排序完成后，才通过行号变化来改变词典顺序。
其中 Dic_ 就是要排序的字典。
Me.PassVal 传递值，避免VB中对象与非对象加不加Set的尴尬！
代码改了，跳出Dictionary的框，用经典的【快速排序法】！.........
'--排序--
Public Function Sort(Optional ByVal ColumnIndex As Variant = 0, Optional ByVal DESC As Boolean = False) As Boolean
'ColumnIndex 指定排序依据列(列名/列号)0=主键
'DESC=True 从大到小排序；DESC=False 从小到大排序
On Error GoTo Err1
Dim SubName As String, SubTxt As String
SubName = "Sort"
SubTxt = "排序" '
'参数处理
ReDim SortCArr_(0) '清空数组
If Me.Count <= 1 Then Exit Function
'确定排序【依据列】
Dim Ci As Long: Ci = Me.ColumnIndex(ColumnIndex) '列定位
If Ci < 0 Then Exit Function
SortCArr_ = Column_(Ci) '排序【依据列】数据数组
Dim i As Long, MaxI As Long, Index As Long
'【依据列】索引数组
MaxI = Dic_.Count - 1
Dim IndexArr() As Long, IndexLen As Long: ReDim IndexArr(0 To MaxI)
Dim ErrDic As New Scripting.Dictionary, ErrRet As Long '异常值词典（作为最小值 单独处理）
Dim ErrIndexArr() As Long
IndexLen = -1
For Index = 0 To MaxI
ErrRet = ReValue(SortCArr_(Index))
If ErrRet < 0 Then '特殊处理
ErrDic.Add Index, ErrRet
Else '一般处理
IndexLen = IndexLen + 1
IndexArr(IndexLen) = Index
End If
Next
If IndexLen >= 0 Then '一般处理 排序
ReDim Preserve IndexArr(0 To IndexLen) '调整 索引数组
Call qSort(IndexArr, 0, IndexLen) '【索引】快速排序
End If
If ErrDic.Count > 0 Then '特殊排序
ErrIndexArr = ErrSort(ErrDic)
End If
'转移字典内容
Dim Keys() As Variant, Key As Variant
Keys = Dic_.Keys 'Key数组
SortCArr_ = Dic_.Items 'Item数组
Dic_.RemoveAll '清空字典
'重新装填字典
If DESC Then '降序
If IndexLen > 0 Then '一般处理
For i = UBound(IndexArr) To 0 Step -1
Index = IndexArr(i)
Dic_.Add Keys(Index), SortCArr_(Index)
Next
End If
If ErrDic.Count > 0 Then '添加特殊值
For i = UBound(ErrIndexArr) To 0 Step -1
Index = ErrIndexArr(i)
Dic_.Add Keys(Index), SortCArr_(Index)
Next
End If
Else '升序
If ErrDic.Count > 0 Then '添加特殊值
For i = 0 To UBound(ErrIndexArr)
Index = ErrIndexArr(i)
Dic_.Add Keys(Index), SortCArr_(Index)
Next
End If
If IndexLen > 0 Then '一般处理
For i = 0 To UBound(IndexArr)
Index = IndexArr(i)
Dic_.Add Keys(Index), SortCArr_(Index)
Next
End If
End If
ReDim SortCArr_(0) '清空数组
Sort = True
Exit Function
Err1:
Debug.Print Me.Name & "[" & Me.ClassTypeName & "]." & SubName & " [" & SubTxt & "]错误！" & Chr(13) & Err.Description
ReDim SortCArr_(0) '清空数组
End Function
Private Function ErrSort(Dic As Scripting.Dictionary) As Long() '特殊排序，返回Index顺序数组
On Error GoTo Err1
Dim Arrt() As Variant, IArr() As Long, i As Long
Arrt = SortCArr_ '保存
SortCArr_ = Dic.Items '排序比较值
ReDim IArr(0 To Dic.Count - 1)
For i = 0 To Dic.Count - 1 '内部位置
IArr(i) = i
Next
Call qSort(IArr, LBound(IArr), UBound(IArr))
SortCArr_ = Arrt '恢复
For i = 0 To Dic.Count - 1 '转换成全局Index
IArr(i) = Dic.Keys(IArr(i))
Next
ErrSort = IArr
Exit Function
Err1:
Debug.Print Me.Name & "[" & Me.ClassTypeName & "].[ErrSort]错误！" & Chr(13) & Err.Description
End Function
Private Function qSort(Arr() As Long, ByVal p As Long, ByVal r As Long) '数组快速排序 升序
Dim q As Long, i As Long
If p >= r Then Exit Function
q = p
For i = p To r - 1
If SortCArr_(Arr(i)) < SortCArr_(Arr(r)) Then
swap Arr(i), Arr(q)
q = q + 1
End If
Next i
swap Arr(q), Arr(r)
qSort Arr, p, q - 1
qSort Arr, q + 1, r
Exit Function
End Function
Private Sub swap(a As Long, b As Long) '交换值
Dim t As Long
t = a: a = b: b = t
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-7-17 10:40
