Các bạn giúp mình hàm tự tạo tách các chữ cái họ tên tiếng Việt để làm mã nhân viên (1 người xem)

[SA_DQ]

Mình muốn tất thẩy các loại họ tên người Việt đều được hàm này đưa về dạng có 3 chữ cái, như ví dụ sau:

TT | HoTen | => | Mã |
1|Đỗ Quan Sang|=>|DQS|
2|Công Tằng Tôn Nữ Minh Nguyệt|=>|CMN|
3|Hồ Ơn|=>|HOn|
4|Ưng Ăn Ốc|=>|UAO|
5|Ừa Ư|=>|UaU|
6|Ỹ Ú|=>|YU_|
7|. . . .|=>|...|
..|. . . |. . .|...|

(Ghi chú: Bạn nào chưa quá 30 bài đăng trong BOX 'Lập trình' này thì chỉ cần giúp mình xử lý các tên ở 2 mục đầu thôi cũng được)

Rất biết ơn & hậu tạ những bạn nào quan tâm giúp đỡ hiệu quả nhất!

 

[nmhung49]

Mình muốn tất thẩy các loại họ tên người Việt đều được hàm này đưa về dạng có 3 chữ cái, như ví dụ sau:
(Ghi chú: Bạn nào chưa quá 30 bài đăng trong BOX 'Lập trình' này thì chỉ cần giúp mình xử lý các tên ở 2 mục đầu thôi cũng được)
Rất biết ơn & hậu tạ những bạn nào quan tâm giúp đỡ hiệu quả nhất!

Em xin đóng góp 2 mục đầu tiên code này chưa loại bỏ Tiếng Việt có dấu nhen anh

Function TT(ByVal Ten As String) As String
  Dim Arr, KQ As String, lTen As Long
  On Error Resume Next
  Arr = split(WorksheetFunction.Trim(Ten), " ")
    If UBound(Arr) <= 2 Then
  
        For lTen = 0 To UBound(Arr)
            KQ = KQ & Left(Arr(lTen), 1)
        Next
        TT = KQ
    
    Else
  
        KQ = Left(Arr(0), 1)
        For lTen = UBound(Arr) - 1 To UBound(Arr)
            KQ = KQ & Left(Arr(lTen), 1)
        Next
        TT = KQ
    
    End If
End Function

 

[le tin]

Trên cơ sở code của bạn nmhung49 mình chỉnh theo yêu cầu :
Function TT(ByVal Ten As String) As String
Dim Arr, KQ As String, lTen As Long
On Error Resume Next
Arr = Split(WorksheetFunction.Trim(Ten), " ")
KQ = Left(Arr(0), 1)
If UBound(Arr) = 1 Then
If Len(Arr(1)) > 1 Then
KQ = KQ & Mid(Arr(1), 1, 2)
ElseIf Len(Arr(0)) > 1 Then
KQ = Mid(Arr(0), 1, 2) & Arr(1)
Else
KQ = KQ & Arr(1) & "_"
End If
Else
For lTen = UBound(Arr) - 1 To UBound(Arr)
KQ = KQ & Left(Arr(lTen), 1)
Next
End If
TT = KQ
End Function

 

[ndu96081631]

Các bạn chưa để ý 1 chuyện: Họ tên có thể có dấu tiếng Việt nhưng khi chuyển thành mã thì phải bỏ hết mấy cái dấu này
Ví dụ: Ừa Ư chuyển thành UaU
Ẹc... Ẹc... đâu có dễ ăn thế
------------
Thật ra bài này chỉ cần dùng Split mà không cần đến vòng lập gì cả ---> Cái khó là loại bỏ dấu tiếng Việt ấy (mà loại bài toán này nhớ không lầm đã có trên diễn đàn rồi thì phải)`

 

[SA_DQ]

Trên cơ sở code của bạn nmhung49 mình chỉnh theo yêu cầu :

Rất mong 2 bạn NMHung49 & Le Tin tiếp tục chỉnh sửa để đạt được hàm =TT("Đỗ Đăng Danh") sẽ trả về là DDD, chứ không fải ĐĐD
Với yêu cầu hàm thỏa & chuyển fụ âm không giống ai 'Đ' sang 'D' khi đứng trong mã;

Rất mong các bạn tiếp tục.

Bạn đặt theo cách này sẽ bị trùng mã

Không lo đâu bạn, với CSDL 1 ngàn người thường ta chỉ cần thêm 1 ký số hay ký tự vô sau là đủ xài trong 15 năm lưu trữ ấy chứ bộ!
Đây là các ký tự có thể xài để nối tiếp mà không ai có thể nghi ngờ hay bắt bẽ:
"012. . .789ABCD. . . F@$#_?"

Xin cảm ơn các bạn & cũng Rất mong các bạn gần xa tiếp tục hỗ trợ giải quyết vấn đề.

 

[nmhung49]

Rất mong 2 bạn NMHung49 & Le Tin tiếp tục chỉnh sửa để đạt được hàm =TT("Đỗ Đăng Danh") sẽ trả về là DDD, chứ không fải ĐĐD
Với yêu cầu hàm thỏa & chuyển fụ âm không giống ai 'Đ' sang 'D' khi đứng trong mã;

Vậy em lồng hàm chuyển mã vào chắc không có vấn đề gì hả anh?

Function TTat(ByVal Ten As String) As String
Dim Arr, KQ As String, lTen As Long, charcode

On Error Resume Next
Arr = Split(WorksheetFunction.Trim(Ten), " ")
KQ = Left(Arr(0), 1)
    If UBound(Arr) = 1 Then
        If Len(Arr(1)) > 1 Then
            KQ = KQ & Mid(Arr(1), 1, 2)
                ElseIf Len(Arr(0)) > 1 Then
                    KQ = Mid(Arr(0), 1, 2) & Arr(1)
                Else
                    KQ = KQ & Arr(1) & "_"
        End If
    Else
        For lTen = UBound(Arr) - 1 To UBound(Arr)
            KQ = KQ & Left(Arr(lTen), 1)
        Next
    End If

  Arr = Array("a", "a", "a", "a", "a", "a", "a", "a", "a", "a", "e", _
      "e", "e", "e", "e", "o", "o", "o", "o", "o", "o", "o", "o", "o", _
      "o", "u", "u", "u", "u", "u", "a", "a", "a", "a", "a", "a", "a", _
      "e", "e", "e", "e", "e", "e", "i", "i", "i", "i", "i", "o", "o", "o", "o", _
      "o", "o", "o", "u", "u", "u", "u", "u", "u", "y", "y", "y", "y", "y", "d")
      charcode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
      ChrW(7849), ChrW(7851), ChrW(7853), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
      ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), ChrW(7899), ChrW(7901), ChrW(7903), _
      ChrW(7905), ChrW(7907), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), ChrW(7921), ChrW(225), _
      ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), ChrW(259), ChrW(226), ChrW(233), ChrW(232), _
      ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), ChrW(7881), ChrW(297), ChrW(7883), _
      ChrW(243), ChrW(242), ChrW(7887), ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(250), ChrW(249), _
      ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925), ChrW(273))
  
    For lTen = 0 To UBound(charcode)
        KQ = Replace(KQ, charcode(lTen), Arr(lTen))
        KQ = Replace(KQ, UCase(charcode(lTen)), UCase(Arr(lTen)))
    Next lTen
TTat = KQ
End Function

 

[concogia]

À á, cái chị này lâu lâu muốm "kiểm cha" lại trình độ anh em í mà

Public Function Hyen(CLL) As String
    Dim Tam, Nguon, Thay, Kq, KyTu, I, J, KtDau, KtGiua, KtCuoi, A, B, C
    Nguon = Array(65, 193, 192, 7842, 195, 7840, 194, 7844, 7846, 7848, 7850, 7852, 258, 7854, 7856, 7858, 7860, 7862, 69, 201, 200, 7866, 7868, 7864, 202, 7870, 7872, 7874, 7876, 7878, 73, 205, 204, 7880, 296, 7882, 79, 211, 210, 7886, 213, 7884, 416, 7898, 7900, 7902, 7904, 7906, 212, 7888, 7890, 7892, 7894, 7896, 85, 218, 217, 7910, 360, 7908, 431, 7912, 7914, 7916, 7918, 7920, 68, 272, 66, 67, 71, 72, 75, 76, 77, 78, 80, 81, 82, 83, 84, 86, 88, 89, 221, 7922, 7926, 7928, 7924)
    Thay = Array("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", "I", "I", "I", "I", "I", "I", "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", "U", "U", "D", "D", "B", "C", "G", "H", "K", "L", "M", "N", "P", "Q", "R", "S", "T", "V", "X", "Y", "Y", "Y", "Y", "Y", "Y")
    Tam = Split(CLL, " ")
        If UBound(Tam) = 1 Then
            For I = LBound(Tam) To UBound(Tam)
                KyTu = VBA.AscW(Left(Tam(I), 1))
                    For J = LBound(Nguon) To UBound(Nguon)
                        If Nguon(J) = KyTu Then
                            Kq = Kq & Thay(J): Exit For
                        End If
                    Next J
            Next I
                If Len(CLL) = 3 Then
                    Kq = Kq & "_"
                Else
                    Kq = IIf(Len(Tam(UBound(Tam))) > 1, Kq & Mid(Tam(UBound(Tam)), 2, 1), Left(Kq, 1) & Mid(Tam(LBound(Tam)), 2, 1) & Right(Kq, 1))
                End If
        ElseIf UBound(Tam) = 2 Then
            For I = LBound(Tam) To UBound(Tam)
                KyTu = VBA.AscW(Left(Tam(I), 1))
                    For J = LBound(Nguon) To UBound(Nguon)
                        If Nguon(J) = KyTu Then
                            Kq = Kq & Thay(J): Exit For
                        End If
                    Next J
            Next I
        Else
            KtDau = VBA.AscW(Left(Tam(LBound(Tam)), 1))
            KtGiua = VBA.AscW(Left(Tam(UBound(Tam) - 1), 1))
            KtCuoi = VBA.AscW(Left(Tam(UBound(Tam)), 1))
                For J = LBound(Nguon) To UBound(Nguon)
                    If Nguon(J) = KtDau Then A = Thay(J)
                    If Nguon(J) = KtGiua Then B = Thay(J)
                    If Nguon(J) = KtCuoi Then C = Thay(J)
                Next J
        Kq = A & B & C
    End If
    Hyen = Kq
End Function

Oái oăm quá. Híc
Ăn cơm no rồi mới thấy mình viết dài quá, sửa lại tý thế này cũng được

Public Function ToTe(CLL) As String
    Dim Tam, Nguon, Thay, Kq, KyTu, I, J
    Nguon = Array(65, 193, 192, 7842, 195, 7840, 194, 7844, 7846, 7848, 7850, 7852, 258, 7854, 7856, 7858, 7860, 7862, 69, 201, 200, 7866, 7868, 7864, 202, 7870, 7872, 7874, 7876, 7878, 73, 205, 204, 7880, 296, 7882, 79, 211, 210, 7886, 213, 7884, 416, 7898, 7900, 7902, 7904, 7906, 212, 7888, 7890, 7892, 7894, 7896, 85, 218, 217, 7910, 360, 7908, 431, 7912, 7914, 7916, 7918, 7920, 68, 272, 66, 67, 71, 72, 75, 76, 77, 78, 80, 81, 82, 83, 84, 86, 88, 89, 221, 7922, 7926, 7928, 7924)
    Thay = Array("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", "I", "I", "I", "I", "I", "I", "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", "U", "U", "D", "D", "B", "C", "G", "H", "K", "L", "M", "N", "P", "Q", "R", "S", "T", "V", "X", "Y", "Y", "Y", "Y", "Y", "Y")
    Tam = Split(CLL, " ")
        If UBound(Tam) = 1 Then
            For I = LBound(Tam) To UBound(Tam)
                KyTu = VBA.AscW(Left(Tam(I), 1))
                    For J = LBound(Nguon) To UBound(Nguon)
                        If Nguon(J) = KyTu Then
                            Kq = Kq & Thay(J): Exit For
                        End If
                    Next J
            Next I
                If Len(CLL) = 3 Then
                    Kq = Kq & "_"
                Else
                    Kq = IIf(Len(Tam(UBound(Tam))) > 1, Kq & Mid(Tam(UBound(Tam)), 2, 1), Left(Kq, 1) & Mid(Tam(LBound(Tam)), 2, 1) & Right(Kq, 1))
                End If
        Else
            For I = LBound(Tam) To UBound(Tam)
                KyTu = VBA.AscW(Left(Tam(I), 1))
                    For J = LBound(Nguon) To UBound(Nguon)
                        If Nguon(J) = KyTu Then
                            Kq = Kq & Thay(J): Exit For
                        End If
                    Next J
            Next I
        Kq = IIf(Len(Kq) = 3, Kq, Left(Kq, 1) & Right(Kq, 2))
    End If
    ToTe = Kq
End Function

Híc, hổng biết chiều ăn cơm xong có rút ngắn được tý nào nữa hông

 

[ChanhTQ@]

Hàm =ToTe(ConCòGià) cho ra kết quả đã rất đúng;

Chỉ xin Bạn Cò thêm hàm Trim() trước khi khỏi sự các lệnh của bạn thì càng OK cho người dùng!

Tình thương mến thương.

 

[sealand]

Mình tham gia 1 cái hàm UDF nhẹ thôi, nhưng chấp nhận cả chữ thường chữ hoa, tốc độ nhanh

Option Explicit
Const MyCode = "002240022507843002270784100259078550785707859078610786300226078450784707849078510785300193001920784200195078400025807854078560785807860078
6200194078440784607848078500785200273002720023300232078670786907865002340787107873078750787707879002010020007866078680786400202078700787207
8740787607878002370023607881002970788300205002040788000296078820024300242078870024507885002440788907891078930789507897004170789907901079030
7905079070021100210078860021307884002120788807890078920789407896004160789807900079020790407906002500024907911003610790900432079130791507917
0791907921002180021707910003600790800431079120791407916079180792000253079230792707929079250022107922079260792807924"

Hàm như sau:

Function MakeCode(ByVal ch As String) As String
Dim Tm, Ma, Kt, Vt, i
ch = Replace(ch, "  ", " ")
Tm = Split(ch, " ")
For i = 0 To UBound(Tm)
Kt = Left(Tm(i), 1)
If InStr(1, MyCode, Right("00" & AscW(Kt), 5)) > 0 Then
Vt = (InStr(1, MyCode, Right("00" & AscW(Kt), 5)) - 1) / 5 + 1
Select Case Vt
Case Is < 35
Kt = "A"
Case Is < 37
Kt = "D"
Case Is < 59
Kt = "E"
Case Is < 69
Kt = "I"
Case Is < 103
Kt = "O"
Case Is < 125
Kt = "U"
Case Is < 135
Kt = "Y"
End Select
End If
Ma = Ma & UCase(Kt)
Next
MakeCode = Ma
End Function

MyCode dài qua mình ngắt xuống dòng thôi, trong file ghép lại 1 dòng thôi. Lưu ý Hàm này chỉ dùng với Font Unicode mà thôi.


Xin lỗi, mình gỡ file chưa hoàn thiện để tận dụng tài nguyên. Tham khảo file tại bài http://www.giaiphapexcel.com/forum/...-Việt-để-làm-mã-nhân-viên&p=369530#post369530

 

[ndu96081631]

Vậy em lồng hàm chuyển mã vào chắc không có vấn đề gì hả anh?

Function TTat(ByVal Ten As String) As String
Dim Arr, KQ As String, lTen As Long, charcode

On Error Resume Next
Arr = Split(WorksheetFunction.Trim(Ten), " ")
KQ = Left(Arr(0), 1)
    If UBound(Arr) = 1 Then
        If Len(Arr(1)) > 1 Then
            KQ = KQ & Mid(Arr(1), 1, 2)
                ElseIf Len(Arr(0)) > 1 Then
                    KQ = Mid(Arr(0), 1, 2) & Arr(1)
                Else
                    KQ = KQ & Arr(1) & "_"
        End If
    Else
        For lTen = UBound(Arr) - 1 To UBound(Arr)
            KQ = KQ & Left(Arr(lTen), 1)
        Next
    End If

  Arr = Array("a", "a", "a", "a", "a", "a", "a", "a", "a", "a", "e", _
      "e", "e", "e", "e", "o", "o", "o", "o", "o", "o", "o", "o", "o", _
      "o", "u", "u", "u", "u", "u", "a", "a", "a", "a", "a", "a", "a", _
      "e", "e", "e", "e", "e", "e", "i", "i", "i", "i", "i", "o", "o", "o", "o", _
      "o", "o", "o", "u", "u", "u", "u", "u", "u", "y", "y", "y", "y", "y", "d")
      charcode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
      ChrW(7849), ChrW(7851), ChrW(7853), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
      ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), ChrW(7899), ChrW(7901), ChrW(7903), _
      ChrW(7905), ChrW(7907), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), ChrW(7921), ChrW(225), _
      ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), ChrW(259), ChrW(226), ChrW(233), ChrW(232), _
      ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), ChrW(7881), ChrW(297), ChrW(7883), _
      ChrW(243), ChrW(242), ChrW(7887), ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(250), ChrW(249), _
      ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925), ChrW(273))
  
    For lTen = 0 To UBound(charcode)
        KQ = Replace(KQ, charcode(lTen), Arr(lTen))
        KQ = Replace(KQ, UCase(charcode(lTen)), UCase(Arr(lTen)))
    Next lTen
TTat = KQ
End Function

Làm thế cũng ngon rồi nhưng tôi góp ý chút:
- Đã dùng Split thì cần gì For (với chuổi có 3 từ trở lên, chỉ cần lấy ký đầu của từ thứ nhất + ký tự đầu của từ kế cuối + ký tự đầu của từ cuối)
- Việc Remove dấu nên cho riêng 1 Function (vì đó là 2 công việc khác nhau, có thể dùng riêng biệt được)
Tôi làm như vầy:

Function RemoveMarks(ByVal Text As String) As String
  Dim CharCode, ResText As String, i As Long, tmp As String
  On Error Resume Next
  tmp = Text
  CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                   ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                   ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                   ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                   ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                   ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                   ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                   ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                   ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    tmp = Replace(tmp, CharCode(i), Mid(ResText, i + 1, 1))
    tmp = Replace(tmp, UCase(CharCode(i)), UCase(Mid(ResText, i + 1, 1)))
  Next
  RemoveMarks = tmp
End Function

Function AbbName(ByVal FulName As String) As String
  Dim i As Long, tmp, Arr, lUb As Long
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  Arr = Split(WorksheetFunction.Trim(FulName))
  lUb = UBound(Arr)
  Select Case lUb
    Case Is > 1
      tmp = Left(Arr(0), 1) & Left(Arr(lUb - 1), 1) & Left(Arr(lUb), 1)
    Case Is = 1
      tmp1 = Left(Arr(0), 2)
      tmp2 = Right(Arr(1), 2)
      If Len(tmp1 & tmp2) = 2 Then
        tmp = tmp1 & tmp2 & "_"
      ElseIf Len(tmp1 & tmp2) = 3 Then
        tmp = tmp1 & tmp2
      Else
        tmp = Left(tmp1, 1) & Right(tmp2, 2)
      End If
  End Select
  AbbName = RemoveMarks(tmp)
End Function

Test lại xem nhé

 

[ChanhTQ@]

Các bạn khác cũng như Đất Cảng & NDU tiếp tục sửa giúp nha, theo thống kê dưới đây,

Rất cảm ơn 2 bạn & còn những điều cần bổ sung như sau:

HoTen | Đất Cảng | NDU | Cần đạt
Ủn Ỉn|UI|UIn | UIn
Ôm Thái|OT| Oai | OTh
Châu Ơn|CO|(OK)| COn
Ứ Ưng|UU| Ung | UUn
Ứ Ừ|UU|UU_| UU_

Tóm lại của bạn Đất Cảng còn thiếu vài ký tự; Còn của NDU thì bỏ sót fần đầu của tên , chỉ lấy fần sau của tên trong 1 số trường hợp

Các bạn khác thử đề xuất fương án sửa xem sao?!

Rất cảm ơn các bạn đã & đang cũng như sẽ quan tâm vấn đề này

Năm mới thắng lợi mới!

 

[sealand]

Mã thiếu có lẽ là tại em rồi. Cái chuỗi mã là của Thày Long, em chép rồi sắp xếp lại. Trong khi làm em thấy có 1 số mã trùng nên em xóa bớt đi, hoặc có thể em xóa nhần ấy. Bác phát hiện thiếu chữ nào báo em với em bổ xung.
Em không hiểu trong đáp án của bác lại có mấy chữ nhỏ nhỉ. Vì em hiểu là mã chỉ lấy ký tự đầu trong Họ_Đệm_Tên. Bác giải thích giùm em.
Em thử phân tích yêu cầu của bác xem có đúng không?
-Mã chỉ có 3 ký tự. Nếu họ tên là Nguyễn Cảnh Hoàng Danh thì mã sẽ là: NHD
-Nếu mã chỉ có 1-2 ký tự thì lấy thêm 1 ký tự ở tên, nếu tên có 1 ký tự thì thêm (_)

(Em test rồi, không thiếu ký tự bác ạ)

 

[ChanhTQ@]

-Nếu mã chỉ có 1-2 ký tự thì lấy thêm 1 ký tự ở tên, nếu tên có 1 ký tự thì thêm (_)

Nếu họ & tên chỉ gồm 2 từ thì từ thứ 3 được đưa vô mã sẽ lấy từ từ thứ 2 của tên đưa vô, & không cần viết hoa.

Nếu họ & tên gồm chỉ 2 từ, mà thêm vào đó tên chỉ là 1 ký tự thì lấy thêm ký tự thứ 2 từ [Họ] bỏ thêm vô cho đủ 3; Lúc này từ thêm cũng sẽ không cần dạng viết hoa.
(Chú xem kỹ lại từng dòng của đề bài sẽ luận ra thôi. Khì, khì, . . .

Thêm gạch dưới chỉ khi họ & tên mỗi thứ có 1 ký tự

Cảm ơn nhiều, chú nha!

 

[concogia]

Hàm =ToTe(ConCòGià) cho ra kết quả đã rất đúng;

Chỉ xin Bạn Cò thêm hàm Trim() trước khi khỏi sự các lệnh của bạn thì càng OK cho người dùng!

Tình thương mến thương.

Code Tote còn chưa đạt yêu cầu với tên Ông Hổ, Lê A. Chơi nó code TòTíTe thử xem bác
Em là Cò, bác biểu thêm Cò thì em mới có để cho chứ thêm "Chim" thì ........em chịu, bác có thì bác.......nhét vào

Public Function ToTiTe(Cll) As String
    Dim Tam, Nguon, Thay, Kq, KyTu, i, J, Kytu2
    Nguon = Array(65, 193, 192, 7842, 195, 7840, 194, 7844, 7846, 7848, 7850, 7852, 258, 7854, 7856, 7858, 7860, 7862, 69, 201, 200, 7866, 7868, 7864, 202, 7870, 7872, 7874, 7876, 7878, 73, 205, 204, 7880, 296, 7882, 79, 211, 210, 7886, 213, 7884, 416, 7898, 7900, 7902, 7904, 7906, 212, 7888, 7890, 7892, 7894, 7896, 85, 218, 217, 7910, 360, 7908, 431, 7912, 7914, 7916, 7918, 7920, 68, 272, 66, 67, 71, 72, 75, 76, 77, 78, 80, 81, 82, 83, 84, 86, 88, 89, 221, 7922, 7926, 7928, 7924)
    Thay = Array("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", "I", "I", "I", "I", "I", "I", "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", "U", "U", "D", "D", "B", "C", "G", "H", "K", "L", "M", "N", "P", "Q", "R", "S", "T", "V", "X", "Y", "Y", "Y", "Y", "Y", "Y")
    Tam = Split(Cll, " ")
        If UBound(Tam) = 1 Then
            For i = LBound(Tam) To UBound(Tam)
                KyTu = VBA.AscW(Left(Tam(i), 1))
                    For J = LBound(Nguon) To UBound(Nguon)
                        If Nguon(J) = KyTu Then
                            Kq = Kq & Thay(J): Exit For
                        End If
                    Next J
            Next i
                If Len(Cll) = 3 Then
                    Kq = Kq & "_"
                Else
                       If Len(Tam(UBound(Tam))) > 1 Then
                            Kytu2 = AscW(UCase(Mid(Tam(UBound(Tam)), 2, 1)))
                            For J = LBound(Nguon) To UBound(Nguon)
                                If Nguon(J) = Kytu2 Then Kq = Kq & LCase(Thay(J)): Exit For
                            Next J
                       Else
                            Kytu2 = AscW(UCase(Mid(Tam(LBound(Tam)), 2, 1)))
                            For J = LBound(Nguon) To UBound(Nguon)
                                If Nguon(J) = Kytu2 Then Kq = Left(Kq, 1) & LCase(Thay(J)) & Right(Kq, 1): Exit For
                            Next J
                       End If
                End If
        Else
            For i = LBound(Tam) To UBound(Tam)
                KyTu = VBA.AscW(Left(Tam(i), 1))
                    For J = LBound(Nguon) To UBound(Nguon)
                        If Nguon(J) = KyTu Then
                            Kq = Kq & Thay(J): Exit For
                        End If
                    Next J
            Next i
        Kq = IIf(Len(Kq) = 3, Kq, Left(Kq, 1) & Right(Kq, 2))
    End If
    ToTiTe = Kq
End Function

Tính rút gọn lại nữa nhưng chóng mặt quá, có 5 lon mà "tửng từng tưng" rồi
Híc

 

[sealand]

Bác ChanhTQ kiểm tra giùm em với nha. Em nghĩ là rất nhanh vì chả dùng vòng lặp va chỉ có mấy cái lựa chọn mà thôi

Xin lỗi, mình gỡ file chưa hoàn thiện để tận dụng tài nguyên. Tham khảo file tại bài http://www.giaiphapexcel.com/forum/...-Việt-để-làm-mã-nhân-viên&p=369530#post369530

 

[concogia]

Bác ChanhTQ kiểm tra giùm em với nha. Em nghĩ là rất nhanh vì chả dùng vòng lặp va chỉ có mấy cái lựa chọn mà thôi

Thầy kiểm tra những tên có 4 từ trở lên xem, hình như có gì chưa ổn
Thân

 

[SA_DQ]

Tính rút gọn lại nữa nhưng chóng mặt quá, có 5 lon mà "tửng từng tưng" rồi . . . Híc

Còn zụ này cần quan tân hay mần tiếp nè chú!

Do sự tưng tửng của cấp chính quyền nào đó, mà các em học sinh này có vầy:

Họ Tên Khai sanh | =ToTiTe(CoCòGià) | Lý ra
As Na Wi|AAN|ANW
Mohammath Aly Romi Zan|MAR|MRZ

Mong mọi người chỉnh sửa giúp cho Cò Già, khì, khì . . . (Chắc hắn chưa hết tửng í mà!)

(/ới lại nếu người nhập liệu vô tình có 2 khoảng trắng trong chuỗi họ tên thì báo lỗi; Chuyện này trước tiên tại nhập liệu & bị như vậy cũng đáng!

To SeaLand: Mã sẽ sai hoàn toàn khi họ tên liên quan đến chữ 'N'
Như với chàng Nguyễn Nhã Nhất sẽ cho mã AAA


Chúc mừng năm mới tất thẩy các bạn gần xa!

 

[nmhung49]

(/ới lại nếu người nhập liệu vô tình có 2 khoảng trắng trong chuỗi họ tên thì báo lỗi; Chuyện này trước tiên tại nhập liệu & bị như vậy cũng đáng!

Em thấy nếu nhập 2 khoảng trắng cũng không có vấn đề gì hết mà Anh nên mình cũng không cần bẫy lỗi làm gì, mà nếu dữ khoảng trắng cuối thì công thức Anh Sealand bị lỗi
To Anh Sealand đúng là chữ N có vấn đề, 4 ký từ trở lên thì OK, mà chỉ có chữ N thì bị đổi thành A hết, với tên là Total, Transfer(Purchase) thì cũng bị lỗi, nói chung có nhiều vấn đề quá

 

[sealand]

Mình định bỏ vòng lặp va sử dụng hàm Instr nhưng nó có vấn đề 1 chút.
Nếu làm như sau, hàm gọn hơn và có vẻ chính xác:
1. Khai báo 2 Hằng số:

Option Explicit
Const MaF = "224;225;7843;227;7841;259;7855;7857;7859;7861;7863;226;7845;7847;7849;7851;7853;193;192;7842;195;7840;258;
7854;7856;7858;7860;7862;194;7844;7846;7848;7850;7852;273;272;233;232;7867;7869;7865;234;7871;7873;7875;7877;7879;201;
200;7866;7868;7864;202;7870;7872;7874;7876;7878;237;236;7881;297;7883;205;204;7880;296;7882;243;242;7887;245;7885;244;
7889;7891;7893;7895;7897;417;7899;7901;7903;7905;7907;211;210;7886;213;7884;212;7888;7890;7892;7894;7896;416;7898;7900;
7902;7904;7906;250;249;7911;361;7909;432;7913;7915;7917;7919;7921;218;217;7910;360;7908;431;7912;7914;7916;7918;7920;253;
7923;7927;7929;7925;221;7922;7926;7928;7924"
Const MaKt = "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;d;D;e;e;e;e;e;e;e;e;e;e;e;E;E;E;E;E;E;E;
E;E;E;E;i;i;i;i;i;I;I;I;I;I;o;o;o;o;o;o;o;o;o;o;o;o;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;u;U;U;U;U;
U;U;U;U;U;U;U;y;y;y;y;y;Y;Y;Y;Y;Y"

2.Viết 2 hàm bổ trợ : 1 hàm bỏ dấu và 1 hàm tạo mã

Function MakeCode(ByVal Ch As String) As String
Dim Tm, Ma, Kt
Ch = Replace(Ch, "  ", " ")
Tm = Split(Ch, " ")
If Not IsArray(Tm) Then Exit Function
Select Case UBound(Tm)
Case Is = 0
Ma = BDau(Left(Tm(0), 1))
Case Is = 1
Ma = BDau(Left(Tm(0), 1)) & BDau(Left(Tm(1), 1))
Case Is > 1
Ma = BDau(Left(Tm(0), 1)) & BDau(Left(Tm(UBound(Tm) - 1), 1)) & BDau(Left(Tm(UBound(Tm)), 1))
End Select
Ma = UCase(Ma)
On Error Resume Next
If Len(Ma) < 3 And UBound(Tm) = 1 Then Ma = Ma & IIf(Len(Tm(1)) > 1, BDau(Mid(Tm(1), 2, 1)), "")
If Len(Ma) < 3 And Len(Trim(Tm(0))) > 1 And IsArray(Tm) Then Ma = Ma & BDau(Mid(Tm(0), 2, 1))
If Len(Ma) < 3 And Len(Ma) > 0 Then Ma = Ma & "_"
MakeCode = Ma
End Function
'=====================================
Function BDau(ByVal Kt As String) As String
Dim i, Tm, Tm1, Ch
Ch = Kt
Tm = Split(MaF, ";")
Tm1 = Split(MaKt, ";")
For i = 0 To UBound(Tm)
If Tm(i) = AscW(Ch) Then
Ch = Tm1(i)
Exit For
End If
Next
BDau = Ch
End Function

Nói chung, viết hàm như thế này trước hết giải quyết các công việc chính đã. Sử lý lỗi đôi khi phải sử dụng mới biết.
Về sử lý khoảng Space có lẽ như thế này mới triệt để:

................
Ch=Trim(Ch)
Do while Instr(1,Ch,"  ")>0
Ch=Replace(Ch,"  "," ")
Loop
................

Xin lỗi, mình gỡ file chưa hoàn thiện để tận dụng tài nguyên. Tham khảo file tại bài http://www.giaiphapexcel.com/forum/...-Việt-để-làm-mã-nhân-viên&p=369530#post369530

 

[nmhung49]

Mình định bỏ vòng lặp nhưng sử dụng hàm Instr nhưng nó có vấn đề 1 chút.
Nếu làm như sau, hàm gọn hơn và có vẻ chính xác:

Với 1 chữ mà dài quá vì dụ "Nguyễn" thì lấy Ng_ không biết ý anh SA_DQ thế nào còn nếu người ta đánh dữ khoảng trống cuối cùng thì hàm bị lỗi. Cho em xin hô anh với bác SA và chú Sealand nhen

 

[SA_DQ]

Rất vui & cảm ơn SeaLand nhiều vì những bài viết thực sự bổ ích trong topic này!

Mình sẵn có danh sách gần 1.100 em học sinh để thử các hàm mà các bạn đưa ra;

Nhờ vậy mình vẫn fải nhờ các bạn sửa giúp hàm tự tạo của bạn Sealand trong trường hợp như sau:

HoTen | =MakeCode() | Lý ra
Ầu Ơ|AOu|AuO
Hồ Á|HAo|HoA

Xin chân thành cảm ơn các bạn đã & đang quan tâm đến đề tài này

Chúc khỏe!



Bổ sung sau khi bấm nút gởi bài:

Với 1 chữ mà dài quá vì dụ "Nguyễn" thì lấy Ng_ không biết ý anh SA_DQ thế nào

Khi nhập liệu đầu năm học cho danh sách đầu cấp của học sinh, ta có thể nhập như vậy; (Hay nhập liệu cho hàng loạt nhân viên mới chuyển về,. . . )nhưng theo mình, khi đã nhập xong toàn bộ số học sinh đầu cấp, ta dùng fương thức Replace trong exxcel để chuyễn về dạng chuẩn

Trong CSDL không nên có chứa 'Ng.', V. , T. ,. . . hay thậm chí Ng, T , V. . .

Tất nhiên nhấn mạnh với chú 1 điều là, trên CSDL ta làm việc với mã đối tượng chứ không làm việc trực tiếp với tên đối tượng, chú đồng í với tôi về vấn đề này mới được.

Thân ái!

 

[sealand]

Các bạn sửa giùm (Bỏ đoạn code bài trước vào hàm). Như vậy, hết lỗi MHung nêu và kể cả cao hứng gõ cách chữ dăm ba cái Space

Hàm sẽ là:

Function MakeCode(ByVal Ch As String) As String
Dim Tm, Ma, Kt
Ch = Trim(Ch)
Do While InStr(1, Ch, "  ") > 0
Ch = Replace(Ch, "  ", " ")
Loop
Tm = Split(Ch, " ")
If Not IsArray(Tm) Then Exit Function
Select Case UBound(Tm)
Case Is = 0
Ma = BDau(Left(Tm(0), 1))
Case Is = 1
Ma = BDau(Left(Tm(0), 1)) & BDau(Left(Tm(1), 1))
Case Is > 1
Ma = BDau(Left(Tm(0), 1)) & BDau(Left(Tm(UBound(Tm) - 1), 1)) & BDau(Left(Tm(UBound(Tm)), 1))
End Select
Ma = UCase(Ma)
On Error Resume Next
If Len(Ma) < 3 And UBound(Tm) = 1 Then Ma = Ma & IIf(Len(Tm(1)) > 1, BDau(Mid(Tm(1), 2, 1)), "")
If Len(Ma) < 3 And Len(Trim(Tm(0))) > 1 And IsArray(Tm) Then Ma = Ma & BDau(Mid(Tm(0), 2, 1))
If Len(Ma) < 3 And Len(Ma) > 0 Then Ma = Ma & "_"
MakeCode = Ma
End Function
'-------------------------------------------------------------------------------------------------
Function BDau(ByVal Kt As String) As String
Dim i, Tm, Tm1, Ch
Ch = Kt
Tm = Split(MaF, ";")
Tm1 = Split(MaKt, ";")
For i = 0 To UBound(Tm)
If Tm(i) = AscW(Ch) Then
Ch = Tm1(i)
Exit For
End If
Next
BDau = Ch
End Function

 

[sealand]

Hì, môi trường mạng giao tiếp văn bản nên mãi mới hiểu ý bác
Hàm sẽ là:

Function MakeCode(ByVal Ch As String) As String
Dim Tm, Ma, Kt
Ch = Trim(Ch)
Do While InStr(1, Ch, "  ") > 0
Ch = Replace(Ch, "  ", " ")
Loop
Tm = Split(Ch, " ")
If Not IsArray(Tm) Then Exit Function
Select Case UBound(Tm)
Case Is = 0
Ma = BDau(Left(Tm(0), 1))
Case Is = 1
Ma = BDau(Left(Tm(0), 1)) & BDau(Left(Tm(1), 1))
Case Is > 1
Ma = BDau(Left(Tm(0), 1)) & BDau(Left(Tm(UBound(Tm) - 1), 1)) & BDau(Left(Tm(UBound(Tm)), 1))
End Select
Ma = UCase(Ma)
On Error Resume Next
If Len(Ma) < 3 And UBound(Tm) = 1 Then Ma = Ma & IIf(Len(Tm(1)) > 1, BDau(Mid(Tm(1), 2, 1)), "")
If Len(Ma) < 3 And Len(Trim(Tm(0))) > 1 And IsArray(Tm) Then Ma = Left(Ma, 1) & BDau(Mid(Tm(0), 2, 1)) & Right(Ma, Len(Ma) - 1)
If Len(Ma) < 3 And Len(Ma) > 0 Then Ma = Ma & "_"
MakeCode = Ma
End Function
'-------------------------------------------
Function BDau(ByVal Kt As String) As String
Dim i, Tm, Tm1, Ch
Ch = Kt
Tm = Split(MaF, ";")
Tm1 = Split(MaKt, ";")
For i = 0 To UBound(Tm)
If Tm(i) = AscW(Ch) Then
Ch = Tm1(i)
Exit For
End If
Next
BDau = Ch
End Function

Xin phép mọi người mình gỡ bỏ các file bài trước cho đỡ tốn tài nguyên.

 

[ndu96081631]

Rất cảm ơn 2 bạn & còn những điều cần bổ sung như sau:

HoTen | Đất Cảng | NDU | Cần đạt
Ủn Ỉn|UI|UIn | UIn
Ôm Thái|OT| Oai | OTh
Châu Ơn|CO|(OK)| COn
Ứ Ưng|UU| Ung | UUn
Ứ Ừ|UU|UU_| UU_

Tóm lại của bạn Đất Cảng còn thiếu vài ký tự; Còn của NDU thì bỏ sót fần đầu của tên , chỉ lấy fần sau của tên trong 1 số trường hợp

Em gõ lộn!
Dùng LEFT tự nhiên lại lộn xộn ở đâu 2 thằng RIGHT
Sửa lại đây:

Function AbbName(ByVal FulName As String) As String
  Dim i As Long, tmp, Arr, lUb As Long
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  Arr = Split(WorksheetFunction.Trim(FulName))
  lUb = UBound(Arr)
  Select Case lUb
    Case Is > 1
      tmp = Left(Arr(0), 1) & Left(Arr(lUb - 1), 1) & Left(Arr(lUb), 1)
    Case Is = 1
      tmp1 = Left(Arr(0), 2)
      tmp2 = [COLOR=#ff0000][B]Left[/B][/COLOR](Arr(1), 2)
      If Len(tmp1 & tmp2) = 2 Then
        tmp = tmp1 & tmp2 & "_"
      ElseIf Len(tmp1 & tmp2) = 3 Then
        tmp = tmp1 & tmp2
      Else
        tmp = Left(tmp1, 1) & [COLOR=#ff0000][B]Left[/B][/COLOR](tmp2, 2)
      End If
  End Select
  AbbName = RemoveMarks(tmp)
End Function

Nói chung, bài này mà đi dùng vòng lập thì chỉ tổ... khổ thân (Split ra mà lựa cho nó khoẻ)
Ẹc... Ẹc...

 

[ThuNghi]

Em ùng thử Dic xem sao, code quá dài, đúng thì rút gọn lại nhưng em thắc mắc về đặt mã cho tên có 2 chữ như Ầu Ơ ... thấy lạ lạ.

Dim ArrKgDau, ArrUni
Dim Dic As Object, i&, nR&
Dim tmpStr$, Txt$, tmpAsc$
Function AccName(ByVal FulName As String) As String
ArrUni = Array("97", "225", "224", "7843", "227", "7841", "259", "7855", "7857", "7859", "7861", "7863", "226", "7845", "7847", "7849", "7851", "7853", "101", "233", "232", "7867", "7869", "7865", "234", "7871", "7873", "7875", "7877", "7879", "105", "237", "236", "7881", "297", "7883", "111", "243", "242", "7887", "245", "7885", "244", "7889", "7891", "7893", "7895", "7897", "417", "7899", "7901", "7903", "7905", "7907", "117", "250", "249", "7911", "361", "7909", "432", "7913", "7915", "7917", "7919", "7921", "121", "253", "7923", "7927", "7929", "7925", "273", "65", _
        "193", "192", "7842", "195", "7840", "258", "7854", "7856", "7858", "7860", "7862", "194", "7844", "7846", "7848", "7850", "7852", "69", "201", "200", "7866", "7868", "7864", "202", "7870", "7872", "7874", "7876", "7878", "73", "205", "204", "7880", "296", "7882", "79", "211", "210", "7886", "213", "7884", "212", "7888", "7890", "7892", "7894", "7896", "416", "7898", "7900", "7902", "7904", "7906", "85", "218", "217", "7910", "360", "7908", "431", "7912", "7914", "7916", "7918", "7920", "89", "221", "7922", "7926", "7928", "7924", "272")
ArrKgDau = Array("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", "i", "i", "i", "i", "i", "i", "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", "u", "u", "y", "y", "y", "y", "y", "y", "d", "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", "I", "I", "I", "I", "I", "I", _
        "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", "U", "U", "Y", "Y", "Y", "Y", "Y", "Y", "D")
TaoDic
Arr = Split(WorksheetFunction.Trim(FulName))
Select Case UBound(Arr)
  Case Is = 0
    Txt = ""
  Case Is = 1 'TH nay ten co 2 chu
    'ky tu 1
    tmpAsc = CStr(AscW(Left(Arr(LBound(Arr)), 1)))
    If Not Dic.Exists(tmpAsc) Then
      tmpStr = Left(Arr(LBound(Arr)), 1)
      Txt = tmpStr
    Else
      nR = Dic.Item(tmpAsc)
      Txt = ArrKgDau(nR)
    End If
    'ky tu 2
    'TH chu thu 2 co 1 ky tu va chu 1 có 2 ky tu
    If Len(Arr(UBound(Arr))) = 1 Then
      If Len(Arr(LBound(Arr))) > 1 Then
        tmpAsc = CStr(AscW(Mid(Arr(LBound(Arr)), 2, 1)))
        If Not Dic.Exists(tmpAsc) Then
          tmpStr = Mid(Arr(LBound(Arr)), 2, 1)
          Txt = Txt & tmpStr
        Else
          nR = Dic.Item(tmpAsc)
          Txt = Txt & ArrKgDau(nR)
        End If
      End If
    End If
    'ky tu 2
    tmpAsc = CStr(AscW(Left(Arr(UBound(Arr)), 1)))
    If Not Dic.Exists(tmpAsc) Then
      tmpStr = Left(Arr(UBound(Arr)), 1)
      Txt = Txt & tmpStr
    Else
      nR = Dic.Item(tmpAsc)
      Txt = Txt & ArrKgDau(nR)
    End If
    'ky tu 3
    If Len(Arr(UBound(Arr))) > 1 Then
      tmpAsc = CStr(AscW(Mid(Arr(UBound(Arr)), 2, 1)))
      If Not Dic.Exists(tmpAsc) Then
        tmpStr = Mid(Arr(UBound(Arr)), 2, 1)
        Txt = Txt & tmpStr
      Else
        nR = Dic.Item(tmpAsc)
        Txt = Txt & ArrKgDau(nR)
      End If
    Else
      If Len(Txt) = 3 Then
        Txt = Txt
      Else
        Txt = Txt & "_"
      End If
    End If
  Case Else 'Truong co ten co > 3 chu
   'ky tu 1
    tmpAsc = CStr(AscW(Left(Arr(LBound(Arr)), 1)))
    If Not Dic.Exists(tmpAsc) Then
      tmpStr = Left(Arr(LBound(Arr)), 1)
      Txt = tmpStr
    Else
      nR = Dic.Item(tmpAsc)
      Txt = ArrKgDau(nR)
    End If
    'ky tu 2
    tmpAsc = CStr(AscW(Left(Arr(UBound(Arr) - 1), 1)))
    If Not Dic.Exists(tmpAsc) Then
      tmpStr = Left(Arr(UBound(Arr) - 1), 1)
      Txt = Txt & tmpStr
    Else
      nR = Dic.Item(tmpAsc)
      Txt = Txt & ArrKgDau(nR)
    End If
    'ky tu 3
    tmpAsc = CStr(AscW(Left(Arr(UBound(Arr)), 1)))
    If Not Dic.Exists((tmpAsc)) Then
      tmpStr = Left(Arr(UBound(Arr)), 1)
      Txt = Txt & tmpStr
    Else
      nR = Dic.Item((tmpAsc))
      Txt = Txt & ArrKgDau(nR)
    End If
End Select
Erase ArrKgDau, ArrUni
Set Dic = Nothing
AccName = Txt
End Function
Sub TaoDic()
Set Dic = CreateObject("Scripting.Dictionary")
For i = LBound(ArrUni) To UBound(ArrUni)
  tmpStr = ArrUni(i)
  Dic.Add tmpStr, i
Next i
End Sub

 

[ndu96081631]

Em ùng thử Dic xem sao, code quá dài, đúng thì rút gọn lại nhưng em thắc mắc về đặt mã cho tên có 2 chữ như Ầu Ơ ... thấy lạ lạ.

Nếu để tăng tốc cho code thì dùng Dictionary là hợp lý nhất
Tuy nhiên code của ThuNghi cũng cần cải tiến lại vài chổ:
1> Biến Dic đặt kiểu Public và Sub TaoDic để riêng như thế rất hợp lý... Tuy nhiên trong Function AccName lúc nào cũng gọi TaoDic sau đó lại Set Dic = Nothing là không hợp lý ---> Lý ra phải If Dic is Nothing then TaoDic ---> chừng nào không có thì mới tạo, có rồi tạo làm gì... THỪA... Và nếu đã tạo rồi thì cứ để yên đấy mà xài, Set Dic = Nothing có phải là uổng phí quá không? Bộ chữ cái tiếng Việt này đâu có thay đoi
2> Biến ArrKgDau tại sao không để nó ở dạng chuỗi? Vầy cũng được vậy:
ArrKgDau = "aaaaaaaaaaaaaaaaaaeeeeeeeeeeeeiiiiiioooooooooooooooooouuuuuuuuuuuuyyyyyydAAAAAAAAAAAAAAAAAAEEEEEEEEEEEEIIIIII_"
3> Chỉ cần nạp chữ thường, chữ HOA khỏi cần (có UCase làm chi)
-----------------
Theo giải thuật của ThuNgh, tôi sẽ sửa lại thế này:

Public Dic As Object
Sub SetDic()
  Dim CharCode, ResText As String, i As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                   ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                   ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                   ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                   ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                   ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                   ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                   ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                   ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    Dic.Add CharCode(i), Mid(ResText, i + 1, 1)
  Next
End Sub

Function RemoveMarks(ByVal Text As String) As String
  Dim i As Long, tmp As String, sCh As String
  On Error Resume Next
  tmp = Text
  If Dic Is Nothing Then SetDic ''<---- Cho nay nham tiet kiem
  For i = 1 To Len(tmp)
    sCh = Mid(tmp, i, 1)
    If Dic.Exists(sCh) Then ''<--- Cho nay kiem tra chu thuong
      tmp = Replace(tmp, sCh, Dic.Item(sCh))
    ElseIf Dic.Exists(LCase(sCh)) Then   ''<--- Cho nay kiem tra chu HOA
      tmp = Replace(tmp, sCh, UCase(Dic.Item(LCase(sCh))))
    End If
  Next
  RemoveMarks = tmp
End Function

Function AbbName(ByVal FulName As String) As String
  Dim i As Long, tmp, Arr, lUb As Long
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  Arr = Split(WorksheetFunction.Trim(FulName))
  lUb = UBound(Arr)
  Select Case lUb
    Case Is > 1
      tmp = Left(Arr(0), 1) & Left(Arr(lUb - 1), 1) & Left(Arr(lUb), 1)
    Case Is = 1
      tmp1 = Left(Arr(0), 2)
      tmp2 = Left(Arr(1), 2)
      If Len(tmp1 & tmp2) = 2 Then
        tmp = tmp1 & tmp2 & "_"
      ElseIf Len(tmp1 & tmp2) = 3 Then
        tmp = tmp1 & tmp2
      Else
        tmp = Left(tmp1, 1) & Left(tmp2, 2)
      End If
  End Select
  AbbName = RemoveMarks(tmp)
End Function

Ngoài ra, thuật toán như ThuNghi đã làm sẽ rút ngắn số lần quét (chỉ quét qua tối đa 3 lần thay vì phải quét nguyên 1 bảng chữ cái)

 

[SA_DQ]

Các cao thủ đã nhanh chóng giải quyết vấn đề hết sức rốt ráo. Xin chân thành cảm ơn;

Tuy nhiên mong mỏi một số thành viên tầm tầm bậc trung thì tham gia chưa được nhiều. . . Đành hẹn dịp khác vậy nha;

/(/hân dịp xuân về, chúc cộng đồng ta thành đạt, sức khỏe & trần đầy hạnh phúc.

 

[concogia]

Còn zụ này cần quan tân hay mần tiếp nè chú!

Do sự tưng tửng của cấp chính quyền nào đó, mà các em học sinh này có vầy:

Họ Tên Khai sanh | =ToTiTe(CoCòGià) | Lý ra
As Na Wi|AAN|ANW
Mohammath Aly Romi Zan|MAR|MRZ

Mong mọi người chỉnh sửa giúp cho Cò Già, khì, khì . . . (Chắc hắn chưa hết tửng í mà!)

(/ới lại nếu người nhập liệu vô tình có 2 khoảng trắng trong chuỗi họ tên thì báo lỗi; Chuyện này trước tiên tại nhập liệu & bị như vậy cũng đáng!

Chúc mừng năm mới tất thẩy các bạn gần xa!

Không ngủ được, nhìn bài này: Không ngủ được. Chị HYen viết:

Mình muốn tất thẩy các loại họ tên người Việt đều được hàm này đưa về dạng có 3 chữ cái, như ví dụ sau:

Tên người Việt sao có As Na Wi. Híc
Thấy ThuNghi sử dụng Dic mình cũng thử viết bài này với Dic xem sao

Public Function TeTo(Cll) As String
    Dim Tam, Nguon, Thay, Kq, KyTu1, KyTu2, KyTu3, d, I
        Set d = CreateObject("scripting.dictionary")
        Nguon = Array(65, 193, 192, 7842, 195, 7840, 194, 7844, 7846, 7848, 7850, 7852, 258, 7854, 7856, 7858, 7860, 7862, 69, 201, 200, 7866, 7868, 7864, 202, 7870, 7872, 7874, 7876, 7878, 73, 205, 204, 7880, 296, 7882, 79, 211, 210, 7886, 213, 7884, 416, 7898, 7900, 7902, 7904, 7906, 212, 7888, 7890, 7892, 7894, 7896, 85, 218, 217, 7910, 360, 7908, 431, 7912, 7914, 7916, 7918, 7920, 68, 272, 66, 67, 71, 72, 75, 76, 77, 78, 80, 81, 82, 83, 84, 86, 88, 89, 221, 7922, 7926, 7928, 7924, 70, 87, 90, 74)
        Thay = Array("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", "I", "I", "I", "I", "I", "I", "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", "U", "U", "D", "D", "B", "C", "G", "H", "K", "L", "M", "N", "P", "Q", "R", "S", "T", "V", "X", "Y", "Y", "Y", "Y", "Y", "Y", "F", "W", "Z", "J")
            For I = LBound(Nguon) To UBound(Nguon)
                d.Add (Nguon(I)), Thay(I)
            Next I
                Cll = Application.WorksheetFunction.Trim(Cll)
                Tam = Split(Cll, " ")
                If UBound(Tam) = 1 Then
                    KyTu1 = d.Item(AscW(UCase(Left(Tam(LBound(Tam)), 1))))
                    KyTu2 = d.Item(AscW(UCase(Left(Tam(UBound(Tam)), 1))))
                        If Len(Cll) = 3 Then
                            Kq = KyTu1 & KyTu2 & "_"
                        ElseIf Len(Tam(UBound(Tam))) > 1 Then
                            KyTu3 = LCase(d.Item(AscW(UCase(Mid(Tam(UBound(Tam)), 2, 1)))))
                            Kq = KyTu1 & KyTu2 & KyTu3
                        Else
                            KyTu3 = LCase(d.Item(AscW(UCase(Mid(Tam(LBound(Tam)), 2, 1)))))
                            Kq = KyTu1 & KyTu3 & KyTu2
                        End If
                Else
                    KyTu1 = d.Item(AscW(UCase(Left(Tam(LBound(Tam)), 1))))
                    KyTu2 = d.Item(AscW(UCase(Left(Tam(UBound(Tam) - 1), 1))))
                    KyTu3 = d.Item(AscW(UCase(Left(Tam(UBound(Tam)), 1))))
                    Kq = KyTu1 & KyTu2 & KyTu3
                End If
    TeTo = Kq
End Function

Mà sao ThuNghi viết dài thế nhỉ.
Híc

 

[SA_DQ]

Đây là đề bài cho các bạn sàng sàng bật trung nha, Cấm các cao thủ động tay chưn!

Nhờ các cao thủ mà chúng ta đã có hàm trích li các chữ cái thích hợp theo 1 qui luật để làm tiền đề tạo mã.

Nhưng ta đi chưa đến đích cuối. Trong các mã tạo thành có rất nhiều các mã trùng, như trong bảng ví dụ sau:

HoTen | Nu | DTc | Ma | Ma_
Nguyễn Tấn Hộp|||NTH|
Nguyễn Thanh Hiền|X||NTH|
Nguyễn Thanh Hoài|||NTH|
Nguyễn Thị Hoa|X||NTH|
Nguyễn Thị Hồng|X||NTH|
Nguyễn Thị Huyền|X||NTH|
Nguyễn Thị Huyền|X||NTH|
Nguyễn Thị Thanh Hiếu|X||NTH|
Nguyễn Thị Thanh Hương|X||NTH|
Nguyễn Thiện Hảo|||NTH|
Nguyễn Thông|||NTh|
. . . ||. .|. . .|

Ta đã biết rằng một CSDL nhân sự đúng đắn, một khi ta tạo cho mỗi nhân vật 1 mã duy nhất.
Như vậy nhiệm vụ tiếp theo của chúng ta là thêm ký số hay ký tự ( như 0,1,2,. . . 9,A,B,C. . . .,Z,@,#,$) nối vô hàm tự tạo trên để đạt yêu cầu đề ra.

Cụ thể nhiệm vụ, đó là:

(/iết 1 macro để duyệt theo danh sách học sinh của 1 trường thuộc huyện Tân Fú nào đó, nhằm nối thêm ký tự vô cột /trường Ma để [Ma_] trở thành mã duy nhất.



Chúc các bạn thành công, & Chúc Xuân thắng lợi!

 

[ThuNghi]

Nhờ các cao thủ mà chúng ta đã có hàm trích li các chữ cái thích hợp theo 1 qui luật để làm tiền đề tạo mã.

Nhưng ta đi chưa đến đích cuối. Trong các mã tạo thành có rất nhiều các mã trùng, như trong bảng ví dụ sau:

HoTen | Nu | DTc | Ma | Ma_
Nguyễn Tấn Hộp|||NTH|
Nguyễn Thanh Hiền|X||NTH|
Nguyễn Thanh Hoài|||NTH|
Nguyễn Thị Hoa|X||NTH|
Nguyễn Thị Hồng|X||NTH|
Nguyễn Thị Huyền|X||NTH|
Nguyễn Thị Huyền|X||NTH|
Nguyễn Thị Thanh Hiếu|X||NTH|
Nguyễn Thị Thanh Hương|X||NTH|
Nguyễn Thiện Hảo|||NTH|
Nguyễn Thông|||NTh|
. . . ||. .|. . .|

Ta đã biết rằng một CSDL nhân sự đúng đắn, một khi ta tạo cho mỗi nhân vật 1 mã duy nhất.
Như vậy nhiệm vụ tiếp theo của chúng ta là thêm ký số hay ký tự ( như 0,1,2,. . . 9,A,B,C. . . .,Z,@,#,$) nối vô hàm tự tạo trên để đạt yêu cầu đề ra.

Cụ thể nhiệm vụ, đó là:

(/iết 1 macro để duyệt theo danh sách học sinh của 1 trường thuộc huyện Tân Fú nào đó, nhằm nối thêm ký tự vô cột /trường Ma để [Ma_] trở thành mã duy nhất.



Chúc các bạn thành công, & Chúc Xuân thắng lợi!

E xin góp ý phần tạo mã cho CSDL như sau:
1/ Nếu mã HS mà có chữ thường và chữ hoa thì rất dễ nhầm. E đề xuất chỉ nên dùng chữ hoa.
2/ Tạo 1 code tạo mã thì không khó nhưng chả lẽ mỗi lần update thêm 1 học sinh phải duyệt lại danh mục, rất dễ sai do mã bị thay thế.
Trong nội dung topic này là rèn luyện viết code, tư duy tổng hợp. Nhưng e nghĩ rằng nên hướng tới việc tạo mã trên CSDL sao cho dễ làm, dễ quản lý. Vấn đề tạo ID Code này có rất nhiều luồng suy nghĩ khác nhau như:
- Tạo mã cho gợi nhớ.
- Tạo mã cho hệ thống và số hóa.
Nên chăng Bác Sa nên hướng theo tư duy số như Tax Code, số CMND ...
Còn theo hướng trên, ví dụ trường có > 1.000 học sinh có mã NTH hay NTh ... và chỉ toàn nữ thì đặt làm sao bây giờ. XNTH_AA, XNTH_AB ... trong đó
X: Giới tính nữ.
NTH: Họ tên
AA, AB là phân biệt nhưng chỉ phân biệt được 26 x 26 à.
Vậy qua topic này mình nên bàn về việc tạo mã luôn.
Cám ơn các Bác nhiều.

 

[SA_DQ]

Đồng í với ThuNghi về việc nên xài chữ cái hoa, không xài chữ thường;

/(hông đồng í với cậu về 1 trường có 1.000 học sinh có trùng mã TTH là không tưởng.
Trong CSDL trên 1.090 em trên, trùng nhiều nhất chỉ là 15 trường hợp là tối đa;
Do vậy trường cỡ 2.000-2.500 học sinh vẫn chỉ độ dài mã là 5

Tất nhiên cũng có thể xài toàn số trong mã; Khi đó theo mình nghỉ, ta fải bắt đầu từ số 1001 (cho em đầu tiên nhập học) cho đến 2001 cho 1 ngàn học sinh kế tiếp. Nhưng xài kiểu này cả chúng ta lẫn các em khó nhớ mã của mình khi cần.

Mong có ý kiến tiếp cùng trao đổi

/(/hưng các bạn khác hãy đưa macro của mình lên nha, rất mong!

 

[ptm0412]

- Căn cứ vào đề xuất của chị ThuNghi về mã giới tính
- Căn cứ vào khẳng định của chị HYen về việc trùng 3 ký tự đầu của mã trong khoảng trên dưới 15
- Căn cứ vào bảng alphabet có 26 chữ cái
- Căn cứ vào yêu cầu chỉ tạo mã cho DS có sẵn, thêm bớt không tính
- Căn cứ vào việc chỉ cho thành viên bậc trung làm

Nay đề xuất hướng giải quyết:

I. Điều 1: Thuật toán

1. Tạo 1 Sub, không dùng Function
2. Tạo 1 Dic
3. Khai báo 1 Array kết quả 1 cột
4. Duyệt cột mã 3 ký tự (có trùng) và cột giới tính:

- Nếu mã chưa có trong Dic:​

• [*=1]Add mã vào Dic.Key và 65 vào Dic.Item[*=1]Kết quả dòng i của Array kết quả = Mã & IIf(giới tính = "X", "X", "Y") & "A"

- Nếu mã đã có trong Dic:
​

• Tìm Item của mã trong Dic, tăng nó lên 1, giả sử được n
• Ghi n vào Item của Dic
• Kết quả dòng i của Array kết quả = Mã & IIf(giới tính = "X", "X", "Y") & Chr(n)

5. Gán kết quả xuống cột cần thiết.

II. Điều 2: Thi hành

Anh chị em bậc trung cố gắng thi hành

III. Điều 3: Thưởng phạt

Phần thưởng là 2 chai sưa bắp.

 

[ndu96081631]

Nhờ các cao thủ mà chúng ta đã có hàm trích li các chữ cái thích hợp theo 1 qui luật để làm tiền đề tạo mã.

Nhưng ta đi chưa đến đích cuối. Trong các mã tạo thành có rất nhiều các mã trùng, như trong bảng ví dụ sau:


Ta đã biết rằng một CSDL nhân sự đúng đắn, một khi ta tạo cho mỗi nhân vật 1 mã duy nhất.
Như vậy nhiệm vụ tiếp theo của chúng ta là thêm ký số hay ký tự ( như 0,1,2,. . . 9,A,B,C. . . .,Z,@,#,$) nối vô hàm tự tạo trên để đạt yêu cầu đề ra.

Cụ thể nhiệm vụ, đó là:

(/iết 1 macro để duyệt theo danh sách học sinh của 1 trường thuộc huyện Tân Fú nào đó, nhằm nối thêm ký tự vô cột /trường Ma để [Ma_] trở thành mã duy nhất.



Chúc các bạn thành công, & Chúc Xuân thắng lợi!

Chuyện còn lại này quá đơn giản! Lại tiếp tục dùng Dictionary là mọi thứ trở nên đơn giản như ăn khoai thôi ---> kiểm tra sự tồn tại của mã, nếu chưa có thì nạp vào, có rồi thì.. thêm giống gì đó vào mã
Ẹc... Ẹc...

 

[sealand]

Mình thêm 1 đề xuất, đây là dạng có thể dùng Dic hay không. Vậy mình theo nhóm chủ trương không dùng Dic. Sau này Bác Sa và các Mod căn cứ chấm cho 2 nhóm:
-Ưu tiên giải thuật đơn giản, dễ viết, dễ dùng mà hiệu quả.
-Tốc độ tốt.
-100% không trùng mã.
-Chấp nhận các trường hợp kể cả toàn trường trùng tên họ, lót.
(Theo mình bỏ qua cách xác định mã kiểu: XXX0001---XXX1000: Vì đây là cách đạt yêu cầu nhưng về mặt giải thuật không đáng nói)

Anh em cố lên nha

 

[ptm0412]

1. Trước tiên, xin thông báo:

Điều kiện như đề bài đã nêu: Số mã gốc (3 ký tự) trùng không quá 26.

Kết quả có dạng ZZZXA:

ZZZ là mã gốc,
X có 2 giá trị X và Y (Nữ và Nam)
A chạy từ A đến Z

2. Sau đó xin cảnh báo:

Nhóm dùng Dic:
- Số vòng lặp = đúng số dòng của dữ liệu.
- Xử lý 60.000 dòng trong 0.8 - 0.9 giây.

 

[ChanhTQ@]

Bài này các bạn sơ cấp & thông thạo vòng lặp & hàm MID() có thể làm được;

Mã nguồn sẵn có gồm chuỗi 3 ký tự, như HDT (Họ, đệm, Tên như trên đã nêu)
Nối thêm 1 ký số hay ký tự từ Const "0123...89ABC...Z"

Thời gian cho 1.100 dòng dữ liệu trên sẽ là 1.9'' - tạm chấp nhận được;
Cái lợi là dễ bảo trì, hiểu tường tận về các câu lệnh trong macro
Hay nhất sẽ là: Thấy macro không fải là quá khó để chinh fục nó!

Chúc vui & nhiều thành công.

 

[sealand]

Bác Sa hay Bác Mỹ Up giùm cho xin cái danh sách 60.000 mã để anh em Test thử cho thống nhất xem sao được không ? (Hì, ngồi tạo cái DS ngại quá anh ơi mà chép dán thì lại sợ vượt cái mức 26 mã trùng)

 

[ptm0412]

Tạo mã đâu có khó gì, viết vài câu code là ra

Sub tao() 
Dim Arr(1 To 60000, 1 To 1) 
For i = 1 To 60000    
   Arr(i, 1) = Chr(65 + Int(Rnd() * 26)) & Chr(65 + Int(Rnd() * 26)) & Chr(65 + Int(Rnd() * 26)) 
Next 
[D2].Resize(60000, 1) = Arr 
test 
End Sub

Tuy nhiên, để thống nhất, xin vui lòng lấy file dưới đây, đã tạo sẵn 60.000 mã gốc. Sau khi chạy code chính để tạo mã vào cột E, dùng code này để kiểm tra, nếu kết quả là 60.000 thì đạt yêu cầu kết quả không trùng:

Sub test()
 Dim Arr Arr = Range("E2:E60001").Value 
With CreateObject("Scripting.dictionary")     
For i = 1 To 60000
        If Not .Exists(Arr(i, 1)) Then  .Add Arr(i, 1), i     
Next     
MsgBox .Count 
End With 
End Sub

ghi chú: Đã gỡ bỏ file đính kèm để tiết kiệm

 

[ndu96081631]

Xin "nhắc" nhỏ với sư phụ Lão và đại ca Cảng rằng: 2 người hổng phải là "sàng sàng" đâu à nghen!
Chị Yến nói vầy:

[h=2]Đây là đề bài cho các bạn sàng sàng bật trung nha, Cấm các cao thủ động tay chưn![/h]

Em sợ mà xía vào là chị Yến sẽ "chặt" chưn
Ẹc... Ẹc...

 

[ptm0412]

Chị Yến không ác đến nỗi chặt "chưn", nhưng chị í mét bác Chanh, bác Chanh mới ghê, bác í cho mình zô nghĩa trang liệt sĩ nằm chung với bác Khéo.

Cho nên Lão chết tiệt chưa dám đưa code lên, chỉ gợi ý cho quý zị khác mần. Còn Bác Cảng HP thì hông biết có gan hông?

 

[SA_DQ]

/(/ăm mới bới chuyện cũ

(*) Mã nhân viên mà xài ký tự thứ 4 để chỉ nam hay nữ là quá fí & không nên chút nào; Cái zụ fái tính này để trường [FaiTinh] lo là đủ rồi. Nhất là đã chuyển sang VBA thì xài như vậy là chồng chéo không cần thiết!

(*) Các bạn đưa ra 1 CSDL 6 vạn Records chỉ mang tính học thuật thôi; chuyện này không mấy có trong thực tiển;
Nếu là CSDL học sinh thì tối đa là quản lý theo từng trường; Mà qui mô trường học VN chỉ cỡ 6.000 HS SV là cùng.

Nếu là đơn vị bộ đội thì cấp trung đoàn cũng chỉ vài ngàn người; còn cấp trên trường học (như fòng Giáo dục Quận/huyện) hay trung đoàn, người ta quản kiểu tổng thể hơn, chắc vậy.

Trong trong các xí nghiệp thì ngành may là nhiều công nhân viên nhất, qui mô lớn nhất cũng chỉ xít soát vạn người là cùng;

Bỡi vì đưa ra 6 vạn records nên các chàng/nàng trình độ sơ sơ trung cấp thấy đã nản! (NghiaPhuc, BaTê XMENX56,. . . .)

(Ngay đến chàng MinhThien lấp ló cũng không thấy hồ hỡi tham gia. Dù biết rằng chàng Ếch xanh này đã nghiền ngẫm đến chuyện Disc đã nẫu!)

(*) Nếu giả thuyết rằng cần tạo mã cho 6 vạn nhân vật, thì theo danh sách thực tế 1.100 em học sinh ở 1 trường nêu trên chỉ 14-15 trùng nhau 3 mã đầu; Nếu đem con số này nhân lên 80 lần , thì số trùng sẽ là 15*80 = 1.200; Đã như vậy thì mã fải dài 5 ký tự (không có chổ cho mã X/Y nêu fái tính) mới thỏa (36*35~ 1.260).

Thân ái chúc các bạn gặt hái nhiều thành công nhân dịp xuân về!

 

[ptm0412]

6 vạn record chỉ để test tốc độ thôi bác Sa ui, vẫn tuân thủ số mã trùng dưới 26. Tại nhà Cảng iu cầu tốc độ, mà code nhanh chậm hơn nhau ở số lượng nhiều, ít quá chênh lệch không đáng kể, không nhận ra.
Dù vậy, thử nghĩ đến 1 trường 2000 học sinh, chả lẽ tạo mã chỉ 1 năm? Mỗi năm sẽ có thêm dăm ba trăm em mới vào cần tạo mã thêm. Mười năm sẽ là bao nhiêu? Dẫu không đến hàng vạn nhưng cũng phải nghĩ tới.
Ký tự giới tính không cho vào thì thôi, chỉ là nối chuỗi hay không. Vậy thì chỉ 4 ký tự là đủ.

 

[ThuNghi]

1
...

2. Sau đó xin cảnh báo:
Nhóm dùng Dic:
- Số vòng lặp = đúng số dòng của dữ liệu.

Số vòng lặp chỉ = số dòng dữ liệu thì e cũng xin thua.
Chưa nghĩ ra cách nào. Ít ra nếu OK thì cũng > y x số dòng trong đó 27> y > 2.

 

[ptm0412]

Đó chính là ưu điểm của việc dùng Dic cho bài toán này
ThuNghi xem gợi ý về thuật toán dùng Dic của bài trên (#32)

 

[ThuNghi]

Đó chính là ưu điểm của việc dùng Dic cho bài toán này
ThuNghi xem gợi ý về thuật toán dùng Dic của bài trên (#32)

Vấn đề tạo mới toàn bộ mã thì OK số lần lặp là số dòng.
Nhưng nếu trong số 60.000 mã trên đã có 1 số mã rồi và ta chỉ tạo mã cho những hs chưa có mã thôi. Vd: ADOB, ADOY ... thì làm thế nào.

 

[ptm0412]

Trích:

4. Duyệt cột mã 3 ký tự (có trùng) và cột giới tính:

- Nếu mã chưa có trong Dic:​

• 
  [*=1]Add mã vào Dic.Key và 65 vào Dic.Item
  [*=1]Kết quả dòng i của Array kết quả = Mã & IIf(giới tính = "X", "X", "Y") & "A"

- Nếu mã đã có trong Dic:
​

• Tìm Item của mã trong Dic, tăng nó lên 1, giả sử được n
  
• Ghi n vào Item của Dic
• Kết quả dòng i của Array kết quả = Mã & IIf(giới tính = "X", "X", "Y") & Chr(n)

Chỗ xoá bỏ liên quan đến giới tính, không dùng đến nữa
Chắc ThuNghi làm bộ hỏi để được đưa xuống loại "sàng sàng", kiếm độ?

 

[ptm0412]

Vì chỉ cần 4 ký tự, nên không cần 6 vạn cái IIf, cũng không phải nối 6 vạn ký tự X hoặc Y, còn 3/4 thời gian (0.65 giây)
Thôi, ngứa tay quá, đưa code lên để mọi người tham khảo.

Sub FinalCode()
Dim SArr, RArr
Dim i As Long, n As Long, EndR As Long
Application.ScreenUpdating = False
t = Timer
EndR = [D65000].End(xlUp).Row
SArr = Range("D2:D" & EndR).Value
ReDim RArr(1 To EndR - 1, 1 To 1)

With CreateObject("Scripting.dictionary")
For i = 1 To EndR - 1
    If Not .Exists(SArr(i, 1)) Then
        .Add SArr(i, 1), 65
    Else
        .Item(SArr(i, 1)) = .Item(SArr(i, 1)) + 1
    End If
        n = .Item(SArr(i, 1))
        RArr(i, 1) = (SArr(i, 1)) & Chr(n)
Next
End With

Range("E2:E" & EndR) = RArr
Application.ScreenUpdating = True
[F1] = Timer - t
'test
End Sub

Code chính chỉ nằm bên trong With - End With. Không đến nỗi khó sửa chữa vận hành nhỉ?

Về vấn đề hiểu, cũng không phải là khó. Ta đã biết Dic có 2 thành phần là Keys và Items. Key thì duy nhất và không thể sửa chữa, Item thì tuỳ ý điền vào theo ý đồ của ta.

Trước đây ta đã dùng Items để:
- Đếm có bao nhiêu mã duy nhất
- Đánh dấu (ghi số thứ tự) dòng trong SArr để truy cập, hoặc đánh dấu dòng trong RArr để sửa chữa

Hôm nay ta không chỉ ghi Item, đọc Item để xài, mà còn sửa Item để xài lại, sử dụng Item để đếm bao nhiêu lần xuất hiện của mỗi mã trùng. Nhưng thay vì đếm bắt đầu từ 1, ta đếm từ 65 để dùng nó cho hàm Chr(), vì Chr(65) = "A".

 

[ndu96081631]

Vì chỉ cần 4 ký tự, nên không cần 6 vạn cái IIf, cũng không phải nối 6 vạn ký tự X hoặc Y, còn 3/4 thời gian (0.65 giây)
Thôi, ngứa tay quá, đưa code lên để mọi người tham khảo.

.

Đầu năm mà sư phụ đã "ngứa" rồi... chắc năm nay sẽ có nhiều cái để học đây (và chứng tỏ sư phụ cũng còn rất.. phong độ)
Ẹc... Ẹc...
(mà sao hổng thấy "ma" nào vào đây nghiên cứu nhỉ? Ít ra cũng tập dợt tay nghề)

 

[ptm0412]

Lúc chiều Thu Nghi đưa ra 1 bài toán mở rộng:
Giả sử ta đã có 3000 học sinh và đã có 3000 mã theo đúng chuẩn bác Sa.
Đầu năm học mới, có thêm 500 em mới vào, đồng thời có 20 em nghỉ học hoặc chuyển trường. Danh sách học sinh trở thành 3480 học sinh, trong đó có 500 học sinh chưa có mã ( giả sử cho nằm dưới cùng danh sách).

Nếu tạo mã lại từ đầu, thì có khả năng mã cũ đã sử dụng bị đổi, vì DS không đúng 100% thứ tự như DS xưa. Bắt buộc phải tạo mã chỉ cho 500 em mới thôi.

Việc 20 em nghỉ học, lại sinh ra 1 chuyện là:
Giả sử trong danh sách cũ có 6 mã bắt đầu bằng PTM, ký tự thứ 4 từ A đến F. Trong số 20 học sinh nghỉ có 2 em PTMB và PTMD, còn lại PTMA, PMC, PTME và PTMF

Đặt ra 1 vài vấn đề:

- Nếu trong số 500 học sinh mới lại có 1 vài em PTM nữa, thì ký tự thứ 4 xử thế nào? ThuNghi đề xuất bổ sung B, D sau đó mới bắt đầu từ G. Nhưng tôi phản đối. Vì bổ sung B, D, tức là trùng mã, dù mã đó đã nghỉ không còn trong danh sách tạo mã. Nó vẫn còn trong các dữ liệu bảng điểm.

- Nếu học sinh đã nghỉ là PTMB và PTMF, mã cuối là PTME, không bổ sung PTMB, mà căn cứ vào mã cuối E để bắt đầu từ PTMF, thì cũng vẫn trùng F.

- Nếu mã cuối là Z, thì thêm làm sao? (thực ra, mã cuối là Z, khá là hiếm hoi, theo thống kê của bác SA thì rất ít xảy ra).

Theo ý tôi, nhằm tránh trùng mã, khi tạo mã cho học sinh mới, phải dựa trên danh sách mã đầy đủ nhất, nghĩa là bao gồm tất cả học sinh đã nghỉ. Điều này cũng đúng khi tạo mã cho bất kỳ đối tượng nào. Thí dụ mã vật tư, dù vật tư đó không dùng nữa, nhưng trước đây đã từng nhập xuất, dữ liệu đã có, thì không thể dùng mã đó cho mặt hàng khác. Trường hợp đã có Z, tức là đã có đủ 26 mã, thì dùng bộ số hoặc ký tự khác thêm vào.

Như vậy, kể cả thuật toán cũng dễ hơn.

 

[ptm0412]

Với điều kiện khi tạo mã mới cho học sinh mới phải có nguyên bảng DS cũ kèm theo để dò, kể cả học sinh đã nghỉ hoặc đã chuyển trường.
Và danh sách học sinh MỚI nằm dưới cùng hoặc tách biệt 1 cột khác.

Code dùng Dic cũng chỉ chạy số vòng lặp bằng đúng tổng số học sinh cũ + mới.

Thuật toán là:

1. Chạy 1 vòng lặp duyệt qua mã 4 ký tự đã có:
nếu 3 ký tự đầu chưa có thì add 3 ký tự đầu vào Dic.Key, đồng thời add Asc của ký tự thứ 4 vào Dic.Item.
Nếu 3 ký tự đầu đã có trong Dic, nếu ASC(ký tự thứ 4) lớn hơn Item có sẵn, thì thay vào. Nhỏ hơn thì thôi.
Không đụng chạm gì đến nguồn và kết quả, phòng trường hợp DS cũ đã bị đảo thứ tự.

2. Chạy 1 vòng lặp duyệt qua các mã 3 ký tự của HS mới. Thực hiện như bài trên:

Nếu chưa có trong Dic, thì add 3 ký tự đầu vào Key, và add 65 vào Item
Nếu đã có, tăng Item lên 1. Kết quả = mã 3 ký tự & Chr(Dic.Item)

Công việc ít hơn, tốc độ nhanh hơn. Test với việc tạo 500 mã mới không trùng với 60000 mã có sẵn: 0.375s

Sub AddCode()
Dim SArr1, SArr2, RArr
Dim i As Long, n As Long, EndR1 As Long, EndR2 As Long
Dim OldCode As Long, Left3 As String, Right1 As String
Application.ScreenUpdating = False
t = Timer
EndR1 = [A65000].End(xlUp).Row
EndR2 = [B65000].End(xlUp).Row
SArr1 = Range("A2:A" & EndR1).Value
SArr2 = Range("B2:B" & EndR2).Value
ReDim RArr(1 To EndR2 - 1, 1 To 1)

With CreateObject("Scripting.dictionary")
For i = 1 To EndR1 - 1
    Left3 = Left(SArr1(i, 1), 3)
    Right1 = Right(SArr1(i, 1), 1)
    If Not .Exists(Left3) Then
        .Add Left3, Asc(Right1)
    Else
        If Asc(Right1) > .Item(Left3) Then
            .Item(Left3) = Asc(Right1)
        End If
    End If
Next

For i = 1 To EndR2 - 1
    If Not .Exists(SArr2(i, 1)) Then
        .Add SArr2(i, 1), 65
    Else
        .Item(SArr2(i, 1)) = .Item(SArr2(i, 1)) + 1
    End If
    n = .Item(SArr2(i, 1))
    RArr(i, 1) = SArr2(i, 1) & Chr(n)
Next
End With

Range("C2:C" & EndR2) = RArr
Application.ScreenUpdating = True
[f1] = Timer - t
End Sub

 

[♠AceBich♠]

Các Bác GPE quả là siêu phàm về code! em không biết gì về VBA cả nhưng khi thử những đoạn code abbname() thì em thắc mắc là những người có họ tên lớn hơn 4 từ (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LLD ) hoặc ( Công tằng tôn nữ Minh Nguyệt) thì kết quả là (CMN).

Nay em nhờ các Bác cho code về đúng với ký tự đầu của Họ + họ lót (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LTLD ) ; ( Công tằng tôn nữ Minh Nguyệt) thì kết quả là (CTTNMN).

Chân thành cám ơn!

 

[♠AceBich♠]

Các Bác GPE quả là siêu phàm về code! em không biết gì về VBA cả nhưng khi thử những đoạn code abbname() thì em thắc mắc là:

- Những người có họ tên lớn hơn 4 từ (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LLD ) hoặc ( Công tằng tôn nữ Minh Nguyệt) thì kết quả là (CMN).

- Những người có 2 từ: (Danh Lạc) thì ra kết quả là DLa

Nay em nhờ các Bác cho code về đúng với ký tự đầu của Họ + họ lót (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LTLD ) ; ( Công Tằng Tôn Nữ Minh Nguyệt) thì kết quả là (CTTNMN).
Danh Lạc thì ra kết quả là DL

Chân thành cám ơn!

 

[nmhung49]

Các Bác GPE quả là siêu phàm về code! em không biết gì về VBA cả nhưng khi thử những đoạn code abbname() thì em thắc mắc là:

- Những người có họ tên lớn hơn 4 từ (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LLD ) hoặc ( Công tằng tôn nữ Minh Nguyệt) thì kết quả là (CMN).

- Những người có 2 từ: (Danh Lạc) thì ra kết quả là DLa

Nay em nhờ các Bác cho code về đúng với ký tự đầu của Họ + họ lót (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LTLD ) ; ( Công Tằng Tôn Nữ Minh Nguyệt) thì kết quả là (CTTNMN).
Danh Lạc thì ra kết quả là DL

Chân thành cám ơn!

Vậy quá đơn giản rồi dùng code này xem

Function TenTat(ByVal chuoi As String)
Dim ptu, i As Long
ptu = Split(chuoi, " ")
For i = 0 To UBound(ptu)
    TenTat = TenTat & Left(ptu(i), 1)
Next i
End Function

 

[VetMini]

Các Bác GPE quả là siêu phàm về code! em không biết gì về VBA cả nhưng khi thử những đoạn code abbname() thì em thắc mắc là:

- Những người có họ tên lớn hơn 4 từ (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LLD ) hoặc ( Công tằng tôn nữ Minh Nguyệt) thì kết quả là (CMN).

- Những người có 2 từ: (Danh Lạc) thì ra kết quả là DLa

Nay em nhờ các Bác cho code về đúng với ký tự đầu của Họ + họ lót (vd: Lục Tiểu Linh Đồng ) thì chỉ ra kết quả là ( LTLD ) ; ( Công Tằng Tôn Nữ Minh Nguyệt) thì kết quả là (CTTNMN).
Danh Lạc thì ra kết quả là DL

Chân thành cám ơn!

Vậy quá đơn giản rồi dùng code này xem

Function TenTat(ByVal chuoi As String)
Dim ptu, i As Long
ptu = Split(chuoi, " ")
For i = 0 To UBound(ptu)
    TenTat = TenTat & Left(ptu(i), 1)
Next i
End Function

Code của bạn thiếu phần đổi tiếng Việt thành mã La tinh cơ bản (không dấu)

 

[nmhung49]

Code của bạn thiếu phần đổi tiếng Việt thành mã La tinh cơ bản (không dấu)

Em thấy phần loại bỏ không dấu thì trong chủ đề này có rồi nên không ghép vào để cho người hỏi tự ghép vào cho quen