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
Tôi chỉ tài lanh tài lẹt có vài ý kiến thôi vì đã gặp trường hợp sắp xếp tên như vậy rồi. Code để xử lý trong Excel với Sheet, Cell thì tôi tệ lắm nên không hỗ trợ bạn được. Cái giải thuật tôi hay làm là:
