Xin code xếp họ tên theo TCVN3

[huenamdao]

Mình mới tham gia mong các bạn giúp đỡ. Mình đang viết 1 tài liệu trong đó cần code này. Mình có xem thử code trên diễn đàn nhưng chưa hiểu, chỉ mong áp dụng rồi học dần dần (các bạn đừng cười nha). Mong các bạn giúp đỡ mình

 

[SA_DQ]

Vừa qua mình nhận được thư nhờ việc này, nhưng không rành, nên đưa lên đây . . .

Các bạn giúp bạn ấy với nha! ( & đừng gọi mình bằng chị nha!)
Em mới học nên VBA kém lắm. Xin chị thu gọn code này giùm em, em chỉ cần xếp theo TCVN3 thôi vì em cho vào trong tài liệu của em thấy nó chạy chậm lắm. Chị xem hộ em nha

Const CodUni = "225 224 7843 227 7841 259 7855 7857 7859 7861 7863 226 7845 7847 7849 7851 7853 233 232 7867 7869 7865 234 7871 7873 7875 7877 7879 237 236 7881 297 7883 243 242 7887 245 7885 244 7889 7891 7893 7895 7897 417 7899 7901 7903 7905 7907 250 249 7911 361 7909 432 7913 7915 7917 7919 7921 253 7923 7927 7929 7925 273 193 193 192 192 7842 7842 195 195 7840 7840 258 258 7854 7854 7856 7856 7858 7858 7860 7860 7862 7862 194 194 7844 7844 7846 7846 7848 7848 7850 7850 7852 7852 201 201 200 200 7866 7866 7868 7868 7864 7864 202 202 7870 7870 7872 7872 7874 7874 7876 7876 7878 7878 205 204 7880 296 7882 211 211 210 210 7886 7886 213 213 7884 7884 212 212 7888 7888 7890 7890 7892 7892 7894 7894 7896 7896 416 7898 7898 7900 7900 7902 7902 7904 7904 7906 7906 218 218 217 217 7910 7910 360 360 7908 7908 431 7912 7912 7914 7914 7916 7916 7918 7918 7920 7920 221 221 7922 7922 7926 7926 7928 7928 7924 272 "
Const StrVn3 = "¸µ¶·¹¨¾»¼½Æ©ÊÇÈÉËÐÌÎÏѪÕ� �ÓÔÖÝ×ØÜÞãßáâä«èåæçé¬íêëì� �óïñòô­øõö÷ùýúûüþ®¸¸µµ¶¶·· ¹¹¡¡¾¾»»¼¼½½ÆÆ¢¢ÊÊÇÇÈÈÉÉË ËÐÐÌÌÎÎÏÏÑÑ££ÕÕÒÒÓÓÔÔÖÖÝ× ØÜÞããßßááââä䤤èèååææççéé ¥ííêêëëììîîóóïïññòòôô¦øøõ õöö÷÷ùùýýúúûûüüþ§"
Const StrVni = "aùaøaûaõaïaêaéaèaúaüaëaâaáaàaåaãa äeùeøeûeõeïeâeáeàeåeãeäí ì æ ó ò oùoøoûoõoïoâoáoàoåoãoäô ôùôøôûôõôïuùuøuûuõuïö öùöøöûöõöïyùyøyûyõî ñ AÙAùAØAøAÛAûAÕAõAÏAïAÊAêAÉAéAÈAèA� �AúAÜAüAËAëAÂAâAÁAáAÀAàAÅAåAÃAãAÄA äEÙEùEØEøEÛEûEÕEõEÏEïEÂEâEÁEáEÀEà EÅEåEÃEãEÄEäÍ Ì Æ Ó Ò OÙOùOØOøOÛOûOÕOõOÏOïOÂOâOÁOáOÀOàO� �OåOÃOãOÄOäÔ ÔÙÔùÔØÔøÔÛÔûÔÕÔõÔÏÔïUÙUùUØU øUÛUûUÕUõUÏUïÖ ÖÙÖùÖØÖøÖÛÖûÖÕÖõÖÏÖïYÙYùYØY øYÛYûYÕYõÎ Ñ"
Const StrDau = "12345 12345 1234512345 123451234512345 12345 1234512345 1234512345 1122334455 1122334455 11223344551122334455 1122334455123451122334455 1122334455 11223344551122334455 1122334455112233445 "
Const StrMa = "a a a a a az az az az az az azzazzazzazzazzazze e e e e ez ez ez ez ez ez i i i i i o o o o o oz oz oz oz oz oz ozzozzozzozzozzozzu u u u u uz uz uz uz uz uz y y y y y dz a a a a a a a a a a az az az az az az az az az az az az azzazzazzazzazzazzazzazzazzazzazzazze e e e e e e e e e ez ez ez ez ez ez ez ez ez ez ez ez i i i i i o o o o o o o o o o oz oz oz oz oz oz oz oz oz oz oz oz ozzozzozzozzozzozzozzozzozzozzozzu u u u u u u u u u uz uz uz uz uz uz uz uz uz uz uz y y y y y y y y y dz"
Const Unicode = "AkronismAmazoneAntiqueArialBigappleCircleCircle3d Courier NewCrystalFloralFlowdecoGeorgia RefLcalligMerscrbMicrosoft Sans SerifMS Ref Sans SerifMS Ref SerifPalatino LinotypeRockstonStarstrpTahomaTime New RomanVerdanaVictoria"
Sub SortABC()
Range("L4:O303").Select
Selection.Cut
Range("AX4").Select
ActiveSheet.Paste
Range("C4:AE303").Select
Dim VungChon As Range, a, b
Dim ri As Long, rd As Long, rc As Long, ci As Byte, cd As Byte, cc As Byte
Dim vt1 As Byte, vt2 As Byte
Dim CotNhap As String, TenCot As String, Cot3 As String, BangMa As String, FontName As String
'On Error GoTo baoloi'
Set VungChon = Selection
rd = VungChon.Row
rc = rd + VungChon.Rows.Count - 1
cd = VungChon.Column
cc = cd + VungChon.Columns.Count - 1
'===================='
'Kiem tra loi sap xep'
'===================='
If cd = cc Then
Err.Number = 1
GoTo baoloi
ElseIf VungChon.MergeCells Or IsNull(VungChon.MergeCells) Then
Err.Number = 2
GoTo baoloi
ElseIf WorksheetFunction.CountA(Range(Cells(rd, 256), Cells(rc, 256))) > 0 Then
Err.Number = 3
GoTo baoloi
ElseIf Range(Cells(rd, 256), Cells(rc, 256)).MergeCells Or IsNull(Range(Cells(rd, 256), Cells(rc, 256)).MergeCells) Then
Err.Number = 4
GoTo baoloi
End If
Application.ScreenUpdating = False
CotNhap = "G,F,E"
If CotNhap = "" Then Exit Sub
CotNhap = Trim(UCase(CotNhap)) & ","
'========================='
'kiem tra ten cot, bang ma'
'========================='
vt1 = 1
vt2 = InStr(1, CotNhap, ",")
Do
TenCot = Trim(Mid(CotNhap, vt1, vt2 - vt1))
Range(TenCot & rd).Activate
If Selection.Cells.Count = 1 Then
Err.Number = 1
GoTo baoloi
End If
ci = Mid(ActiveCell.Address(, , xlR1C1), InStrRev(ActiveCell.Address(, , xlR1C1), "C") + 1)
baoloi:
Select Case Err.Number
Case 1
MsgBox "Vung sap xep co 1 dong. Khong sap xep !", "Thong bao"
Case 2
MsgBox "Vung sap xep co dinh dang Merge cells. Khong sap xep duoc !", "Thong bao"
Case 3
MsgBox "Cot 256 co du lieu. Khong sap xep duoc !", "Thong bao"
Case 4
MsgBox "Cot 256 co dinh dang Merge cells. Khong sap xep duoc !", "Thong bao"
Case 5
MsgBox "Cot sap xep " & TenCot & " ngoai vung chon !", "Thong bao"
Case 6
MsgBox "Cot cuoi cung la 256, khong sap xep duoc !", "Thong bao"
Case 1004
MsgBox "Khong co ten cot " & TenCot & " !", "Thong bao"
Case Else
End Select
VungChon.Select
End Sub
Function SortUni(text As String) As String
text = text & " "
MaDau = " "
For n = 1 To Len(text) - 1
KyTu = Mid(text, n, 1)
CodKyTu = AscW(KyTu) & String(5 - Len(CStr(AscW(KyTu))), " ")
vitri = (InStr(1, CodUni, CodKyTu, 0) + 4) / 5
If vitri >= 1 Then
KyTu = Trim(Mid(StrMa, vitri * 3 - 2, 3))
If MaDau = " " Then MaDau = Mid(StrDau, vitri, 1)
End If
If Mid(text, n + 1, 1) = " " Then
NewText = NewText & KyTu & Trim(MaDau)
MaDau = " "
Else
NewText = NewText & KyTu
End If
Next
SortUni = NewText
End Function
Function SortVn3(text As String) As String
text = text & " "
MaDau = " "
For n = 1 To Len(text) - 1
KyTu = Mid(text, n, 1)
vitri = InStr(1, StrVn3, KyTu, 0)
If vitri >= 1 Then
KyTu = Trim(Mid(StrMa, vitri * 3 - 2, 3))
If MaDau = " " Then MaDau = Mid(StrDau, vitri, 1)
End If
If Mid(text, n + 1, 1) = " " Then
NewText = NewText & KyTu & Trim(MaDau)
MaDau = " "
Else
NewText = NewText & KyTu
End If
FontName = Cells(rd, ci).Font.Name
If InStr(1, Unicode, FontName) > 0 Then
FontName = "UNI"
ElseIf Left(FontName, 4) = "VNI-" Then
FontName = "VNI"
ElseIf Left(FontName, 3) = ".Vn" Then
FontName = "ABC"
Else
MsgBox "Khong xac dinh duoc font " & FontName & " thuoc bang ma nao !"
Exit Sub
End If

 

[Mr Okebab]

Đừng làm khó mình như vậy.
Trong excel việc sắp xếp theo Unicode rất dễ vì có hỗ trợ.

Vì vậy việc chuyển qua Unicode để sắp xếp là việc nên làm.
Tuy nhiên không nên tích hợp cả việc chuyển đổi vào SUB làm gì, nên xây dựng 1 Function TCVNtoUNI để sử dụng, như vậy gọn gàng hơn nhiều (trên GPE có rất nhiều : Của bác phamduylong, bác TuanVNUni, Binh OverAC . . . )

Thân!

 

[phamduylong]

Mình mới tham gia mong các bạn giúp đỡ. Mình đang viết 1 tài liệu trong đó cần code này. Mình có xem thử code trên diễn đàn nhưng chưa hiểu, chỉ mong áp dụng rồi học dần dần (các bạn đừng cười nha). Mong các bạn giúp đỡ mình

Bạn có thể tham khảo các code sắp xếp tại Công cụ hỗ trợ tiếng Việt cho Excel