Option Explicit
Private Sub S_Sort_random()
Dim rg, R, C, a
Set rg = Sheet1.Range("C4").Resize(100, 10)
a = rg.Value
VBA.Randomize
For R = 1 To UBound(a)
For C = 1 To UBound(a, 2)
a(R, C) = Int(VBA.Rnd * 4) + 1
Next
Next
rg.Value = a
Set rg = Sheet1.Range("AA5").Resize(4, 20)
a = rg.Value
For R = 1 To UBound(a)
For C = 1 To UBound(a, 2)
a(R, C) = Int(VBA.Rnd * 4) + 1
Next
Next
rg.Value = a
End Sub
Private Sub S_SortV_test()
Dim B, a(1 To 10, 1 To 3), I%, j%: I = 1
' a(i, 1) = "z": a(i, 2) = 1: a(i, 3) = 1: i = i + 1
' a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 2: i = i + 1
' a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 4: i = i + 1
' a(i, 1) = "z": a(i, 2) = 2: a(i, 3) = 5: i = i + 1
' a(i, 1) = "a": a(i, 2) = 1: a(i, 3) = 1: i = i + 1
' a(i, 1) = "a": a(i, 2) = 2: a(i, 3) = 1: i = i + 1
' a(i, 1) = "a": a(i, 2) = 5: a(i, 3) = 1: i = i + 1
' a(i, 1) = ChrW(272): a(i, 2) = 2: a(i, 3) = 1: i = i + 1
' a(i, 1) = ChrW(272): a(i, 2) = 4: a(i, 3) = 1: i = i + 1
' a(i, 1) = ChrW(272): a(i, 2) = 1: a(i, 3) = 1: i = i + 1
B = S_Sortv(Sheet1.[B4:F203].Value)
End Sub
Function S_Sortv(ByVal SortArray, Optional ByVal Columns = -1, Optional ByVal sortDescending As Boolean)
On Error GoTo E
Dim data, a(), B(), x(), w(), ww(), iw&, iww&, K&, Min&, C&, R&, I&, L&, u&, z()
Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
Dim lv%, lcol&, col&, V, lines&, fline&, nb&
Dim t1$, t2$, t3$, t4$, it As Boolean
data = SortArray
GoSub I
QuickSortZV data, a, lcol, , , Compare
If u > L Then
fline = lb: lines = ub: col = Columns(L + 1): GoSub L
If iw > 0 Then
For lv = L + 1 To u
lcol = Columns(lv):
If lv < u Then
col = Columns(lv + 1)
End If
If iw > 0 Then
ww = w: iw = 0: Erase w
For iww = 1 To UBound(ww, 2)
I = ww(1, iww)
fline = 1
lines = ww(2, iww)
B = ww(3, iww)
Compare = ww(4, iww)
QuickSortZV data, B, lcol, , , Compare
GoSub L
Next
End If
Next
End If
End If
GoSub z
Exit Function
L:
K = 0
For R = fline To lines
If I > 0 Then
nb = R + I - 1
a(nb) = B(R)
Else
nb = R
End If
If lv < u Then
t1 = data(a(nb), lcol)
If K > 0 Then
If t2 <> t1 Then
If K > 1 And it Then
GoSub w
End If
GoTo l2
Else
If Not it Then
t3 = data(a(nb), col)
If t4 <> t3 Then
it = True
End If
End If
End If
Else
l2: K = 0: Min = nb: t4 = data(a(nb), col): it = False
End If
K = K + 1: GoSub fw
t2 = t1
End If
Next
If K > 1 And it Then
GoSub w
End If
Return
fw:
ReDim Preserve x(1 To K)
x(K) = a(nb)
If Compare = 0 Then
V = data(a(nb), col)
If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
Compare = 1
End If
End If
Return
w:
iw = iw + 1
ReDim Preserve w(1 To 4, 1 To iw)
w(1, iw) = Min
w(2, iw) = K
w(3, iw) = x
w(4, iw) = Compare: Compare = 0
Return
I:
lb = LBound(data)
ub = UBound(data)
lb2 = LBound(data, 2)
ub2 = UBound(data, 2)
If IsNumeric(Columns) Then
If Columns < lb2 Then
ReDim z(lb2 To ub2)
For lcol = lb2 To ub2
z(lcol) = lcol
Next
Columns = z: L = lb2: u = ub2
lcol = Columns(L)
ElseIf Columns > ub2 Then
S_Sortv = data
Exit Function
Else
lcol = Columns
End If
ElseIf IsArray(Columns) Then
L = LBound(Columns)
u = UBound(Columns)
lcol = Columns(L)
Else
Exit Function
End If
ReDim a(lb To ub)
For R = lb To ub
a(R) = R
If Compare = 0 Then
V = data(R, lcol)
If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
Compare = 1
End If
End If
Next
Return
z:
ReDim z(lb To ub, lb2 To ub2)
If sortDescending Then
For R = lb To ub
For C = lb2 To ub2
z(R, C) = data(a(ub - R + 1), C)
Next
Next
Else
For R = lb To ub
For C = lb2 To ub2
z(R, C) = data(a(R), C)
Next
Next
End If
S_Sortv = z
Return
E: S_Sortv = data
End Function
Private Sub QuickSortZV_test()
Debug.Print StrComp(ChrW(272), ChrW(273), 1), ChrW(272) < ChrW(273)
Debug.Print StrComp(ChrW(272), ChrW(273), 1) = 0 And ChrW(272) < ChrW(273)
End Sub
Sub QuickSortZV( _
ByVal SortArray As Variant, _
ArrayTemp(), _
Optional ByVal lngColumn& = -1, _
Optional lngMin& = -1, _
Optional lngMax& = -1, _
Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)
On Error Resume Next
Dim I&, j&, varMid, Temp
Dim lngColTemp As Long
If IsEmpty(SortArray) Then Exit Sub
If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
If lngMin >= lngMax Then Exit Sub
I = lngMin: j = lngMax
varMid = Empty: varMid = SortArray(ArrayTemp((lngMin + lngMax) \ 2), lngColumn)
If IsEmpty(varMid) Then
I = lngMax: j = lngMin
ElseIf IsNull(varMid) Then
I = lngMax: j = lngMin
ElseIf varMid = vbNullString 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
If Compare = vbBinaryCompare Then
While I <= j
While SortArray(ArrayTemp(I), lngColumn) < varMid And I < lngMax: I = I + 1: Wend
While varMid < SortArray(ArrayTemp(j), lngColumn) And j > lngMin: j = j - 1: Wend
If I <= j Then
Swap1: Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
I = I + 1: j = j - 1
End If
Wend
Else
While I <= j
While (StrComp(SortArray(ArrayTemp(I), lngColumn), varMid, 1) = -1 Or (SortArray(ArrayTemp(I), lngColumn) > varMid) And StrComp(SortArray(ArrayTemp(I), lngColumn), varMid, 1) = 0) And I < lngMax: I = I + 1: Wend
While (StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = -1 Or (varMid > SortArray(ArrayTemp(j), lngColumn)) And StrComp(varMid, SortArray(ArrayTemp(j), lngColumn), 1) = 0) And j > lngMin: j = j - 1: Wend
If I <= j Then
Swap2: Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
I = I + 1: j = j - 1
End If
Wend
End If
If (lngMin < j) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, lngMin, j, Compare)
If (I < lngMax) Then Call QuickSortZV(SortArray, ArrayTemp, lngColumn, I, lngMax, Compare)
End Sub
Private Sub S_SortH_test()
Dim a, I, j
a = S_SortH(Sheet1.[O4:AH8].Value, -1, False)
End Sub
Function S_SortH(ByVal SortArray, Optional Rows = 0, Optional sortDescending As Boolean)
On Error GoTo E
Dim data, a(), B(), x(), w(), ww(), iw&, iww&, K&, Min&, C&, R&, I&, L&, u&, z()
Dim lb%, ub&, lb2%, ub2&, Compare As VbCompareMethod
Dim lv%, lrow&, row&, V, lines&, fline&, nb&
Dim t1$, t2$, t3$, t4$, it As Boolean
data = SortArray
GoSub I
QuickSortZH data, a, lrow, , , Compare
If u > L Then
fline = lb2: lines = ub2: row = Rows(L + 1): GoSub L
If iw > 0 Then
For lv = L + 1 To u
lrow = Rows(lv):
If lv < u Then
row = Rows(lv + 1)
End If
If iw > 0 Then
ww = w: iw = 0: Erase w
For iww = 1 To UBound(ww, 2)
I = ww(1, iww)
fline = 1
lines = ww(2, iww)
B = ww(3, iww)
Compare = ww(4, iww)
QuickSortZH data, B, lrow, , , Compare
GoSub L
Next
End If
Next
End If
End If
GoSub z
Exit Function
L:
K = 0
For C = fline To lines
If I > 0 Then
nb = C + I - 1
a(nb) = B(C)
Else
nb = C
End If
If lv < u Then
t1 = data(lrow, a(nb))
If K > 0 Then
If t2 <> t1 Then
If K > 1 And it Then
GoSub w
End If
GoTo l2
Else
If Not it Then
t3 = data(row, a(nb))
If t4 <> t3 Then
it = True
End If
End If
End If
Else
l2: K = 0: Min = nb: t4 = data(row, a(nb)): it = False
End If
K = K + 1: GoSub fw
t2 = t1
End If
Next
If K > 1 And it Then
GoSub w
End If
Return
fw:
ReDim Preserve x(1 To K)
x(K) = a(nb)
If Compare = 0 Then
V = data(row, a(nb))
If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
Compare = 1
End If
End If
Return
w:
iw = iw + 1
ReDim Preserve w(1 To 4, 1 To iw)
w(1, iw) = Min
w(2, iw) = K
w(3, iw) = x
w(4, iw) = Compare: Compare = 0
Return
I:
lb = LBound(data)
ub = UBound(data)
lb2 = LBound(data, 2)
ub2 = UBound(data, 2)
If IsNumeric(Rows) Then
If Rows < lb Then
ReDim z(lb To ub)
For lrow = lb To ub
z(lrow) = lrow
Next
Rows = z
L = lb
u = ub
lrow = Rows(L)
ElseIf Rows > ub Then
S_SortH = data
Exit Function
Else
lrow = Rows
End If
ElseIf IsArray(Rows) Then
L = LBound(Rows)
u = UBound(Rows)
lrow = Rows(L)
Else
Exit Function
End If
ReDim a(lb2 To ub2)
For C = lb2 To ub2
a(C) = C
If Compare = 0 Then
V = data(lrow, C)
If Not IsNumeric(V) And Not IsDate(V) And V <> vbNullString Then
Compare = 1
End If
End If
Next
Return
z:
ReDim z(lb To ub, lb2 To ub2)
If sortDescending Then
For R = lb To ub
For C = lb2 To ub2
z(R, C) = data(R, a(ub - C + 1))
Next
Next
Else
For R = lb To ub
For C = lb2 To ub2
z(R, C) = data(R, a(C))
Next
Next
End If
S_SortH = z
Return
E: S_SortH = data
End Function
Sub QuickSortZH( _
ByVal SortArray As Variant, _
ArrayTemp(), _
Optional lngRow& = -1, _
Optional lngMin& = -1, _
Optional lngMax& = -1, _
Optional Compare As VbCompareMethod = VbCompareMethod.vbBinaryCompare)
On Error Resume Next
Dim I&, j&, varMid, Temp
Dim lngColTemp As Long
If IsEmpty(SortArray) Then Exit Sub
If InStr(TypeName(SortArray), "()") < 1 Then Exit Sub
If lngMin = -1 Then lngMin = LBound(ArrayTemp, 1)
If lngMax = -1 Then lngMax = UBound(ArrayTemp, 1)
If lngMin >= lngMax Then Exit Sub
I = lngMin: j = lngMax
varMid = Empty: varMid = SortArray(lngRow, ArrayTemp((lngMin + lngMax) \ 2))
If IsEmpty(varMid) Then
I = lngMax: j = lngMin
ElseIf IsNull(varMid) Then
I = lngMax: j = lngMin
ElseIf varMid = vbNullString 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
If Compare = vbBinaryCompare Then
While I <= j
While SortArray(lngRow, ArrayTemp(I)) < varMid And I < lngMax: I = I + 1: Wend
While varMid < SortArray(lngRow, ArrayTemp(j)) And j > lngMin: j = j - 1: Wend
If I <= j Then
Swap1: Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
I = I + 1: j = j - 1
End If
Wend
Else
While I <= j
While (StrComp(SortArray(lngRow, ArrayTemp(I)), varMid, 1) = -1 Or (SortArray(lngRow, ArrayTemp(I)) > varMid) And StrComp(SortArray(lngRow, ArrayTemp(I)), varMid, 1) = 0) And I < lngMax: I = I + 1: Wend
While (StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = -1 Or (varMid > SortArray(lngRow, ArrayTemp(j))) And StrComp(varMid, SortArray(lngRow, ArrayTemp(j)), 1) = 0) And j > lngMin: j = j - 1: Wend
If I <= j Then
Swap2: Temp = ArrayTemp(I): ArrayTemp(I) = ArrayTemp(j): ArrayTemp(j) = Temp
I = I + 1: j = j - 1
End If
Wend
End If
If (lngMin < j) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, lngMin, j, Compare)
If (I < lngMax) Then Call QuickSortZH(SortArray, ArrayTemp, lngRow, I, lngMax, Compare)
End Sub
giaiphapexcel.com
, Net Frame không có, Font cũng thiếu
