Function SortTenHoNgaySinh(ByVal aHoTen, ByVal aNgaySinh, ByVal strSort$) As Variant
'Sort Du Lieu theo Ten, Ho và Ngay Sinh
'Thu tu Uu Tien theo trình tu cua chuoi "strSort"
'aHoTen: Mang Ho ten, co 1 cot Ho va Ten hoac có 2 cot gom 1 cot Ho và 1 cot Ten
'aNgaySinh: Mang ngay Sinh
Dim i&, r&, j&, j2&, sCol&, S
Set dic = CreateObject("scripting.dictionary")
sRow = UBound(aHoTen) - LBound(aHoTen) + 1
sCol = UBound(aHoTen, 2) - LBound(aHoTen, 2) + 1
ReDim sArr(1 To sRow, 1 To 3)
ReDim Res(1 To sRow, 1 To 3)
ReDim aRow(1 To sRow, 1 To 2)
j = LBound(aHoTen, 2)
j2 = j + 1
For i = 1 To sRow
aRow(i, 1) = i
r = LBound(aHoTen) + i - 1
If sCol = 2 Then
sArr(i, 1) = aHoTen(r, j)
sArr(i, 2) = aHoTen(r, j2)
sArr(i, 3) = aNgaySinh(r, 1)
ElseIf sCol = 1 Then
S = Split(aHoTen(r, j), " ")
sArr(i, 2) = S(UBound(S))
sArr(i, 1) = Mid(aHoTen(r, j), 1, Len(aHoTen(r, j)) - Len(sArr(i, 2)) - 1)
sArr(i, 3) = aNgaySinh(r, 1)
End If
Next i
strSort = " " & strSort
For i = 1 To Len(strSort)
dic.Item(Mid(strSort, i, 1)) = i
Next i
Call SortChar(2, 1, 1, sRow)
Call AddRes
SortTenHoNgaySinh = Res
End Function
Private Sub SortChar(ByVal j&, ByVal n&, ByVal fRow&, ByVal eRow&)
Dim S(), i&, r&, k&, k2&, fR&, iChar&
ReDim arr(fRow To eRow, 1 To 2)
For i = fRow To eRow
arr(i, 1) = dic.Item(Mid(sArr(aRow(i, 1), j), n, 1))
arr(i, 2) = fRow
Next i
For i = fRow To eRow - 1
For r = i + 1 To eRow
If arr(i, 1) > arr(r, 1) Then
arr(i, 2) = arr(i, 2) + 1
Else
arr(r, 2) = arr(r, 2) + 1
End If
Next r
Next i
tmp = aRow
For i = fRow To eRow
aRow(arr(i, 2), 1) = tmp(i, 1)
aRow(arr(i, 2), 2) = arr(i, 1)
Next i
ReDim S(fRow To eRow, 1 To 2)
tmp = aRow
k = fRow - 1: k2 = fRow - 1
For i = fRow To eRow
If Len(sArr(aRow(i, 1), j)) = n Then
k = k + 1
aRow(k, 1) = tmp(i, 1)
aRow(k, 2) = tmp(i, 2)
Else
k2 = k2 + 1
S(k2, 1) = tmp(i, 1)
S(k2, 2) = tmp(i, 2)
End If
Next i
If k > fRow Then
If j = 2 Then
Call SortChar(1, 1, fRow, k)
ElseIf j = 1 Then
Call SortDate(fRow, k)
End If
End If
iChar = Empty: fR = sRow + 1
If k2 >= fRow Then
For i = fRow To k2
k = k + 1
aRow(k, 1) = S(i, 1)
aRow(k, 2) = S(i, 2) '*****
If iChar <> aRow(k, 2) Then
If fR < k Then
If j = 2 Then
Call SortChar(j, n + 1, fR, k - 1)
ElseIf j = 1 Then
Call SortDate(fRow, k - 1)
End If
End If
'Call Tam 'oooooo
fR = k: iChar = aRow(k, 2)
End If
Next i
If fR < k Then
Call SortChar(j, n + 1, fR, k)
End If
End If
End Sub
Private Sub SortDate(ByVal fRow&, ByVal eRow&)
Dim i&, r&, ngay As Date
ReDim arr(fRow To eRow)
For i = fRow To eRow
arr(i) = fRow
Next i
For i = fRow To eRow - 1
ngay = sArr(aRow(i, 1), 3)
For r = i + 1 To eRow
If ngay > sArr(aRow(r, 1), 3) Then
arr(i) = arr(i) + 1
Else
arr(r) = arr(r) + 1
End If
Next r
Next i
tmp = aRow
For i = fRow To eRow
aRow(arr(i), 1) = tmp(i, 1)
Next i
End Sub
Private Sub AddRes()
Dim j&, i&
For i = 1 To sRow
For j = 1 To 3
Res(i, j) = sArr(aRow(i, 1), j)
Next j
Next i
End Sub