Xin code sắp xếp họ và tên

[duong_nam_dao]

Có bác nào có code sắp xếp họ và tên theo thứ thự a, b,c ...không cho em với. Xin cám ơn các bác

 

[binhtrungqbh]

Bạn thử dùng Code này kiểm tra thế nào nhé:
-------------------
Sub Sort()
On Error GoTo Sort_Err
Dim i As Integer, x As Integer, TotalRow As Integer, TotalCol As Integer
Dim AreaSortAdd As String, SKey1 As String, SKey2 As String, Skey3 As String
Dim Response As Boolean
Dim AreaVal, VOrder1, VOrder2, VOrder3
Dim Col1 As Integer, Col2 As Integer, Col3 As Integer
Dim NList1 As Integer, NList2 As Integer, NList3 As Integer
Dim VungSapxep As String, OrderList As String
Dim OrderID As Integer, z As Integer
Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

'Neu con chi select 1 cell thi select toan bo vung du lieu lien tuc cua bang tinh
If Selection.Cells.Count = 1 Then
Selection.CurrentRegion.Select
End If

'Kiem tra Empty Range. Neu Empty thi thoi khong lam gi ca

If Selection.Rows.Count <= 1 Then
MsgBox "Your selection has a row." & Chr(13) & Chr(10) & "You don't need to sort. " _
& "Bye!", 48, "DBTsort"
Exit Sub
End If

'Xac dinh cac gia tri mo ta vung duoc chon
AreaSortAdd = Selection.Address()
Set AreaSort = Range(AreaSortAdd)
TotalRow = Selection.Rows.Count()
TotalCol = Selection.Columns.Count()

'Khai bao hop thoai VnSort
Set Mydialog = ThisWorkbook.DialogSheets(1)
'Xac dinh cac muc chon mac nhien (Ascending, No Header Row) tren hop thoai VnSort
For i = 1 To Mydialog.OptionButtons.Count Step 2
Mydialog.OptionButtons(i).Value = xlOn
Next
'Neu NSD bo chon muc No Header Row thi goi Sub Dialog1_OpNoHead_Click
Call Dialog1_OpNoHead_Click
'Hien thi hop thoai VnSort
Response = Mydialog.Show
'Neu NSD bam nut lenh OK tren hop thoai VnSort

If Response = True Then 'Bat dau xem xet hoat dong cua cac nut OK & Cancel

'Ap dung cac che do hoat dong cho Excel
With Application
.ScreenUpdating = False 'Tat che do cap nhat man hinh
.StatusBar = "Wellcome to VNsort" 'Hien thi dong chao mung tren StatusBar
End With
'Gan cac tri duoc chon trong cac o SortBy cua hop thoai VnSort
'ListIndex lay cac gia tri nhu sau:
' ListIndex = 0 : khong chon
' ListIndex = 1 : chon muc thu nhat - trong VnSort la muc "None"
' ListIndex = 1+n : chon muc thu 1+n

NList1 = Mydialog.DropDowns(1).ListIndex 'SortBy thu 1
NList2 = Mydialog.DropDowns(2).ListIndex 'SortBy thu 2
NList3 = Mydialog.DropDowns(3).ListIndex 'SortBy thu 3
Col1 = NList1 - 1
Col2 = NList2 - 1
Col3 = NList3 - 1

'va Chen cac cot tam
'Xet SortBy 1 --------------------------------------------------
If NList1 > 1 Then
'Neu SortBy 1 la cot ngoai cung ben phai
'thi noi rong vung chon them 1 cot
'de chuan bi chen them cot tam thu 1 o ngoai bia phai
'va cot tam nay van nam trong vung duoc chon
If NList1 = TotalCol + 1 Then
Selection.Resize(TotalRow, TotalCol + 1).Select
End If
AreaSort.Columns(Col1).Cells(1).Offset(0, 1).Select
ActiveCell.EntireColumn.Insert
'Nhap cong thuc ma hoa cho cell dau tien cua cot tam
ActiveCell.FormulaR1C1 = "=mh1(RC[-1])"
'Copy cong thuc
Selection.Copy
'Va Paste ra toan bo cot tam
Selection.Resize(TotalRow).Select
ActiveSheet.Paste
'Dat ten cho khoa sap xep 1: Key1

Selection.Columns(1).Cells(1).Name = "Key1"

'Kiem tra chieu sap xep duoc chon
If Mydialog.OptionButtons("OpD1").Value = xlOn Then
VOrder1 = xlDescending
Else
VOrder1 = xlAscending
End If
x = 1
'Chinh lai vung chon sau khi them cot tam
AreaSort.Resize(TotalRow, TotalCol + x).Select

End If
'Xet SortBy 2 --------------------------------------------------
If NList2 > 1 Then
'Xet vi tri SortBy2 voi SortBy1
If NList2 < NList1 Then
Selection.Columns(Col2).Cells(1).Offset(0, 1).Select
Else
Selection.Columns(Col2 + 1).Cells(1).Offset(0, 1).Select
End If
ActiveCell.EntireColumn.Insert
'Nhap cong thuc ma hoa cho cell dau tien cua cot tam
ActiveCell.FormulaR1C1 = "=mh1(RC[-1])"
'Copy cong thuc
Selection.Copy
'Va Paste ra toan bo cot tam
Selection.Resize(TotalRow).Select
ActiveSheet.Paste
'Dat ten cho khoa sap xep 1: Key1
Selection.Columns(1).Cells(1).Name = "Key2"
'Kiem tra chieu sap xep duoc chon
If Mydialog.OptionButtons("OpD2").Value = xlOn Then
VOrder2 = xlDescending
Else
VOrder2 = xlAscending
End If
x = 2
AreaSort.Resize(TotalRow, TotalCol + x).Select

End If
'Xet SortBy 3 --------------------------------------------------
If NList3 > 1 Then
'Xem xet su hien dien cua cac SortBy
If NList2 <= 1 Then 'Neu SortBy 2 khong duoc chon
If Col1 > Col3 Then
Selection.Columns(Col3).Cells(1).Offset(0, 1).Select
Else
Selection.Columns(Col3 + 1).Cells(1).Offset(0, 1).Select
End If

Else 'Neu SortBy2 duoc chon

If Col1 > Col2 Or Col1 > Col3 Then
If Col2 < Col3 Then
z = -1
ElseIf Col3 < Col2 Then
z = -2
End If
Selection.Columns(Col3 + x + z).Cells(1).Offset(0, 1).Select
Else
Selection.Columns(Col3 + x).Cells(1).Offset(0, 1).Select
End If
End If 'Ket thuc viec xet su hien dien cua cac SortBy

ActiveCell.EntireColumn.Insert
'Nhap cong thuc ma hoa cho cell dau tien cua cot tam
ActiveCell.FormulaR1C1 = "=mh1(RC[-1])"

'Copy cong thuc
Selection.Copy
'Va Paste ra toan bo cot tam
Selection.Resize(TotalRow).Select
ActiveSheet.Paste

'Kiem tra chieu sap xep duoc chon
If Mydialog.OptionButtons("OpD3").Value = xlOn Then
VOrder3 = xlDescending
Else
VOrder3 = xlAscending
End If

If NList2 <= 1 Then 'Neu SortBy 2 khong duoc chon
'Dat ten cho khoa sap xep : Key2
Selection.Columns(1).Cells(1).Name = "Key2"
VOrder2 = VOrder3
x = 2

Else
Selection.Columns(1).Cells(1).Name = "Key3"
x = 3

End If
AreaSort.Resize(TotalRow, TotalCol + x).Select
End If


'---- Bat dau Sort ------------------------------------------------------------
'
'Yeu cau Excel tinh toan cap nhat du lieu tren bang tinh truoc khi sort
Calculate
Application.StatusBar = "Begin sort..."

If Mydialog.OptionButtons("OpHead").Value = xlOn Then
Selection.Resize(TotalRow - 1, TotalCol + x).Offset(1, 0).Select
End If


VungSapxep = "Vung sap xep: " & Selection.Address & Chr(10) & Chr(13) & OrderList & Chr(10) & Chr(13)

If NList2 <= 1 And NList3 <= 1 Then 'Sort data
Selection.Sort Key1:=Range("Key1").Columns(1), Order1:=VOrder1
'MsgBox VungSapxep & "SortBy 1: " & Range("key1").Address
Range("Key1").Cells(1).EntireColumn.Delete

ElseIf (NList1 > 1 And NList2 > 1 And NList3 <= 1) Or (NList1 > 1 And NList2 <= 1 And NList3 > 1) Then
Selection.Sort Key1:=Range("Key1").Columns(1), Order1:=VOrder1, key2:=Range("Key2").Columns(1), Order2:=VOrder2
'MsgBox VungSapxep & "SortBy 1: " & Range("key1").Address & " SortBy 2: " & Range("key2").Address
Range("Key2").Cells(1).EntireColumn.Delete
Range("Key1").Cells(1).EntireColumn.Delete

Else
Selection.Sort Key1:=Range("Key1").Columns(1), Order1:=VOrder1, key2:=Range("Key2").Columns(1), Order2:=VOrder2, key3:=Range("Key3").Columns(1), Order3:=VOrder3
'MsgBox VungSapxep & "SortBy 1: " & Range("key1").Address & " SortBy 2: " & Range("key2").Address & " SortBy 3: " & Range("key3").Address
Range("Key3").Cells(1).EntireColumn.Delete
Range("Key2").Cells(1).EntireColumn.Delete
Range("Key1").Cells(1).EntireColumn.Delete

End If '---------- Cham dut Sort data -----------------------------------------

 

[voda]

ActiveCell.EntireColumn.Insert
'Nhap cong thuc ma hoa cho cell dau tien cua cot tam
ActiveCell.FormulaR1C1 = "=mh1(RC[-1])"

Mình thấy code này chưa chạy được vì thiếu hàm mh1.

 

[voda]

Nguyên văn bởi duong_nam_dao
Có bác nào có code sắp xếp họ và tên theo thứ thự a, b,c ...không cho em với. Xin cám ơn các bác

Sau đây là code sắp xếp ABC tiếng Việt, hỗ trợ cả 3 loại font: Unicode, VNI-Times, .VnTime. Code này đơn giản vì không có nhiều tùy chọn, các bạn có thể dùng để tích hợp vào các chương trình riêng của mình. Cách sử dụng như sau:
-Chọn vùng cần sắp xếp ( không chọn dòng tiêu đề)
-Nhập tên cột cần sắp xếp vào hộp thoại: A, B, D, G......
Các hàm mã hóa mình mượn trên diễn đàn, không biết tác giả. Xin phép được sử dụng lại.

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"
---------------------------------------------------------------
Sub SortHoTen()
Dim Vungchon As Range
Dim i As Integer, TotalRow As Integer, TotalCol As Integer, FistRow As Integer
Dim TenCot As String, FontNa As String
    Set Vungchon = Selection
           FistRow = Selection.Row
          TotalRow = Selection.Rows.Count
          TotalCol = Selection.Columns.Count
Application.ScreenUpdating = False
    If TotalRow < 2 Then
             MsgBox "Ban phai chon vung can sap xep. Chu y: khong chon dong chua tieu de "
            Exit Sub
    End If
TenCot = InputBox("Chon cot can sap xep", "Thong bao")
FontNa = Range(TenCot & FistRow).Font.Name
Range(TenCot & FistRow).EntireColumn.Insert
        Select Case FontNa
                  Case "Arial", "Times New Roman", "Tahoma", "Verdana"
                       For i = FistRow To TotalRow + FistRow - 1
                           Range(TenCot & i) = MHUni(Range(TenCot & i).Offset(0, 1))
                       Next
                Case "VNI-Times"
                     For i = FistRow To TotalRow + FistRow - 1
                         Range(TenCot & i) = MHVni(Range(TenCot & i).Offset(0, 1))
                    Next
                Case ".VnTime"
                     For i = FistRow To TotalRow + FistRow - 1
                        Range(TenCot & i) = MHVn3(Range(TenCot & i).Offset(0, 1))
                    Next
        End Select
Range(TenCot & FistRow).Name = "Key1"
Vungchon.Resize(TotalRow, TotalCol + 1).Select
Selection.Sort Key1:=Range("Key1").Columns(1), Order1:=xlAscending
Range("Key1").Cells(1).EntireColumn.Delete
Application.ScreenUpdating = True
Cells(1, 1).Select
End Sub
--------------------------------------------------------------------
Function MHUni(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
MHUni = newtext
End Function
-------------------------------------------------------------------
Function MHVn3(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
Next
MHVn3 = newtext
End Function
------------------------------------------------------------------
Function MHVni(text As String) As String
text = text & " "
madau = " "
For i = 1 To Len(text)
  kytu = Mid(text, i, 2)
  Vitri = InStr(1, StrVni, kytu, 0)
  If Vitri = 0 Or Left(kytu, 1) = " " Or Right(kytu, 1) = " " Or Len(kytu) = 1 Then
    kytu = Mid(text, i, 1)
    Vitri = InStr(1, StrVni, kytu, 0)
    If (Asc(kytu) >= 65 And Asc(kytu) <= 122) Or kytu = " " Then
      Vitri = 0
    End If
  Else
    i = i + 1
  End If
  If Vitri > 0 And kytu <> " " Then
    kytu = Trim(Mid(StrMa, (Vitri + 1) * 3 / 2 - 2, 3))
    If madau = " " Then madau = Mid(StrDau, (Vitri + 1) / 2, 1)
  End If
  If Mid(text, i + 1, 1) = " " Then
    newtext = newtext & kytu & Trim(madau)
    madau = " "
  Else
    newtext = newtext & kytu
  End If
Next
MHVni = Left(newtext, Len(newtext) - 1)
End Function

 

[doanhoanghai]

lỗi rồi

có chạy được đâu bạn ! bạn check lại xem sao

 

[tedaynui]

có chạy được đâu bạn ! bạn check lại xem sao

Mình test thấy code vẫn chạy tốt, bạn thử lại xem. Tuy nhiên, code trên chỉ sắp xếp có 1 cột. Ví dụ xếp cột Tên, cột Họ thì không được xét tới.

TDN

 

[phamduylong]

Mình test thấy code vẫn chạy tốt, bạn thử lại xem. Tuy nhiên, code trên chỉ sắp xếp có 1 cột. Ví dụ xếp cột Tên, cột Họ thì không được xét tới.
TDN

Theo bài của bác voda, tôi viết lại và thêm vài phần để cho việc sắp xếp thuận tiện hơn.
Nguyên tắc của thuật toán sắp xếp này là chèn 1 cột phụ để mã hóa dữ liệu và sắp trên cột phụ đó. Sắp xong xóa cột phụ đó đi. Muốn chèn thêm cột phụ thì cột 256 phải không có dữ liệu. Ngoài ra, còn 1 số trường hợp không sắp xếp được. SortABC kiểm tra và loại các trường hợp không sắp xếp được để kết thúc. Nếu không dễ hư dữ liệu vì không thể phuc hồi được.

Các trường hợp SortABC không sắp xếp:
1. Vùng sắp xếp chỉ có 1 dòng hoặc có cột 256
2. Vùng sắp xếp có định dạng Merge cells
3. Cột 256 có dữ liệu hoặc có định dạng Merge cells. Không chèn thêm cột được
4. Nhập tên cột sắp xếp ngoài vùng chọn
5. Nhập tên cột sai

Bảng mã :
Sắp xếp cho 3 bảng mã thông dụng Unicode, VNI Windows, TCVN3-ABC
- Unicode : nhận dạng 24 font Unicode thông dụng (các bạn có thể thêm vào danh sách font Unicode vào hằng Const Unicode
- VNI Windows, TCVN3-ABC: tất cả các font thông dụng
SortABC kiểm tra font trước khi sắp xếp. Nếu không xác định được bảng mã thì không sắp xếp để người dùng kiểm tra font lại.

Số cột sắp xếp 1 lần :
Không hạn chế. Tên cột sắp xếp không phân biệt chữ hoa, thường. Nếu sắp xếp nhiều cột thì tên cột cách nhau dấu phẩy. Thứ tự ưu tiên từ trái qua phải. Ví dụ:
- Sắp xếp 1 cột B thì nhập B hoặc b
- Sắp xếp 4 cột theo thứ tự ưu tiên là D > B > F > A thì nhập d,b,f,a

Chú ý: SortABC chỉ sắp tăng dần

Các bạn xem code bài 8

 

[phamduylong]

Khai báo các hằng:

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 = "AkronismAmazoneAntiqueArialBigappleCircleCircle3dCourier NewCrystalFloralFlowdecoGeorgia RefLcalligMerscrbMicrosoft Sans SerifMS Ref Sans SerifMS Ref SerifPalatino LinotypeRockstonStarstrpTahomaTime New RomanVerdanaVictoria"

Sub SortABC()
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
[COLOR=blue]'====================[/COLOR]
[COLOR=blue]'Kiem tra loi sap xep[/COLOR]
[COLOR=blue]'====================[/COLOR]
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 = InputBox("Sap xep 1 hoac nhieu cot theo thu tu uu tien. Nhap ten cot cach nhau dau phay." & Chr(13) & _
"  Vi du B, D, F" & Chr(13) & Chr(13) & Chr(13) & _
"Nhap ten cac cot can sap xep :", "Sort Unicode, TCVN3-ABC, VNI Window")
If CotNhap = "" Then Exit Sub
CotNhap = Trim(UCase(CotNhap)) & ","
[COLOR=blue]'=========================[/COLOR]
[COLOR=blue]'kiem tra ten cot, bang ma[/COLOR]
[COLOR=blue]'=========================[/COLOR]
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)
  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
  Cot3 = ci & "/" & Cot3
  BangMa = FontName & "/" & BangMa
  vt1 = vt2 + 1
  vt2 = InStr(vt1, CotNhap, ",")
Loop While vt1 < Len(CotNhap)
vt1 = 1
vt2 = 1
Do
  ci = Mid(Cot3, vt1, InStr(vt1, Cot3, "/") - vt1)
  FontName = Mid(BangMa, vt2, InStr(vt2, BangMa, "/") - vt2)
  Range(Cells(rd, ci), Cells(rc, ci)).Insert Shift:=xlToRight
  Select Case FontName
  Case "VNI"
    For ri = rd To rc
      Cells(ri, ci) = SortVni(Cells(ri, ci + 1))
    Next
  Case "ABC"
    For ri = rd To rc
      Cells(ri, ci) = SortVn3(Cells(ri, ci + 1))
    Next
  Case Else
    For ri = rd To rc
      Cells(ri, ci) = SortUni(Cells(ri, ci + 1))
    Next
  End Select
  Range(Cells(rd, cd), Cells(rc, cc + 1)).Select
  Selection.Sort Key1:=Cells(rd, ci), Order1:=xlAscending
  Range(Cells(rd, ci), Cells(rc, ci)).Delete Shift:=xlToLeft
  vt1 = InStr(vt1 + 1, Cot3, "/") + 1
  vt2 = InStr(vt2, BangMa, "/") + 1
Loop While vt1 < Len(CotNhap)
Application.ScreenUpdating = True
Cells(rd, cd).Select
Exit Sub
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
Next
SortVn3 = NewText
End Function

Function SortVni(text As String) As String
text = text & " "
MaDau = " "
For i = 1 To Len(text)
  KyTu = Mid(text, i, 2)
  vitri = InStr(1, StrVni, KyTu, 0)
  If vitri = 0 Or Left(KyTu, 1) = " " Or Right(KyTu, 1) = " " Or Len(KyTu) = 1 Then
    KyTu = Mid(text, i, 1)
    vitri = InStr(1, StrVni, KyTu, 0)
    If (Asc(KyTu) >= 65 And Asc(KyTu) <= 122) Or KyTu = " " Then
      vitri = 0
    End If
  Else
    i = i + 1
  End If
  If vitri > 0 And KyTu <> " " Then
    KyTu = Trim(Mid(StrMa, (vitri + 1) * 3 / 2 - 2, 3))
    If MaDau = " " Then MaDau = Mid(StrDau, (vitri + 1) / 2, 1)
  End If
  If Mid(text, i + 1, 1) = " " Then
    NewText = NewText & KyTu & Trim(MaDau)
    MaDau = " "
  Else
    NewText = NewText & KyTu
  End If
Next
SortVni = Left(NewText, Len(NewText) - 1)
End Function

to tedaynui: anh trả xong nợ sắp xếp 2 cột cho em rồi nhé !

 

[duong_nam_dao]

Lại phiền các bác. Em dốt về vba nên phần này chỉ biết ứng dụng. Nếu chỉ sắp xếp theo bảng mã TCVN3 thì code như thế nào. Em đã thử nhiều lần nhưng không được. Em để cả nên chạy chậm lắm. Mong tin của các bác.

 

[phamduylong]

Lại phiền các bác. Em dốt về vba nên phần này chỉ biết ứng dụng. Nếu chỉ sắp xếp theo bảng mã TCVN3 thì code như thế nào. Em đã thử nhiều lần nhưng không được. Em để cả nên chạy chậm lắm. Mong tin của các bác.

Nếu chỉ cần sắp xếp theo bảng mã duy nhất như TCVN3, Unicode hay VNI Windows thì bạn có xóa bớt đi các hàm Sort... cũng chẳng cải thiện tốc độ bao nhiêu. Vì SortABC chỉ lấy tên font của 1 ô đầu cột để xét bảng mã và giữ bảng mã đó cho cho tất cả các ô trong cột sắp xếp. Trong cột có bấy nhiêu ô thì SortABC phải chạy hàm Sort... để mã hóa bấy nhiêu lần nên bảng càng có nhiều dòng thì thì tốc độ càng chậm.