Maika8008
Thành viên gạo cội
- Tham gia
- 12/6/20
- Bài viết
- 4,765
- Được thích
- 5,742
- Donate (Momo)
- Giới tính
- Nam
Tôi nhớ trên GPE có code sort array đâu đó rồi nhưng quả thực là chức năng tìm kiếm trên GPE sao sao đó mà tôi không tài nào tìm được (!).
Nay tình cờ có được 1 cái Sub sắp xếp 1 cột tăng dần của mảng 2 chiều, tôi sửa lại thành Function và làm thêm 1 cái Function gọi cái kia để sắp xếp thêm cột thứ 2, chia sẻ cho ai đó cần.
(Function trước tôi để nguyên ghi chú của tác giả)
Nay tình cờ có được 1 cái Sub sắp xếp 1 cột tăng dần của mảng 2 chiều, tôi sửa lại thành Function và làm thêm 1 cái Function gọi cái kia để sắp xếp thêm cột thứ 2, chia sẻ cho ai đó cần.
(Function trước tôi để nguyên ghi chú của tác giả)
Rich (BB code):
Function QuickSortArrayF(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
On Error Resume Next
'Sort a 2-Dimensional array
' SampleUsage: sort arrData by the contents of column 3
'
' QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Function
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Function
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Function
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArrayF(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArrayF(SortArray, i, lngMax, lngColumn)
QuickSortArrayF = SortArray
End Function
Function QuickSortArrayF2(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0, Optional lngColumn2 As Long = 0)
Dim SortArr As Variant
Dim i As Long, j As Long, k As Long, d As Long, r As Long
If lngColumn = 0 Then lngColumn = 1
SortArray = QuickSortArrayF(SortArray, , , lngColumn)
ReDim TempArray(1 To UBound(SortArray, 1), 1 To UBound(SortArray, 2))
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
k = k + 1
On Error Resume Next
If SortArray(i, lngColumn) <> SortArray(i + 1, lngColumn) Then
If Err.Number = 9 Then
On Error GoTo 0
GoTo Sort
End If
Sort: If k > 1 Then
ReDim SortArr(1 To k, 1 To UBound(SortArray, 2))
For r = 1 To k
For j = LBound(SortArray, 2) To UBound(SortArray, 2)
SortArr(r, j) = SortArray(i - k + r, j)
Next
Next
SortArr = QuickSortArrayF(SortArr, , , lngColumn2)
For d = i - k + 1 To i
For j = LBound(SortArray, 2) To UBound(SortArray, 2)
SortArray(d, j) = SortArr(d + k - i, j)
Next
Next
k = 0
Else
k = 0
End If
End If
Next
QuickSortArrayF2 = SortArray
End Function
Lần chỉnh sửa cuối:
