Tạo tài khoản cho nhân viên của cơ quan dựa trên họ tên của họ[Đăng bài giúp bạn]

[SA_DQ]

Hiện em đang phải tạo tài khoản cho Nhân viên; Công thức tạo thông tin tài khoản của bên em là: Tên + chữ cái đầu trong họ và tên đệm, ví dụ như dướiđây:

STT

Họ & Tên

Tài Khoản

Len()

1

Cỗ Văn Ẩn

AnCV_012300

11​

2

Lê Ngọc Ánh

AnhLN_01200

11​

3

Nguyễn Hải Anh

AnhNH_01200

4

Nguyễn Thị Kim Anh

AnhNK_01200

5

Nguyễn Thị Ngọc Ánh

AnhNN_01200

6

Nguyễn Anh

AnhNJ_01200

7

Phan Thị Ngọc Ánh

AnhPN_01200

8

Ngô Thị Ánh An

AnNA_012300

9

Nguyễn Ái Ân

AnNA_012301

10

Nhữ Thị Ẩn An

AnNA_012302

11

Nguyễn Lương Trường An

AnNT_012300

12

Khổng Hữu Bang

BangKH_0100

13

Ngô Thị Hòa Biền

BienNH_0100

14

Trần Văn Biên

BienTV_0100

15

Nguyễn Đình Bình

BinhNF_0100

Sau đây là macro tạo tài khoản:

Sub TaoTaiKhoan()   'ABC0000DE00   '
 Dim aTmp, Cls As Range, Rng As Range, sRng As Range
 Const sNum As String = "_01234"
 Dim Rws As Long, DD As Integer, W As Integer, jJ As Long, iTen As Integer
 Dim HTen As String, Ma As String, sTmp As String, MyAdd As String
 
 With Sheets("TK")
    Rws = .[C2].CurrentRegion.Rows.Count
    For Each Cls In .[C2].Resize(Rws)
        HTen = Cls.Value:                   If HTen = "" Then Exit For
        aTmp = Split(HTen, " "):            DD = UBound(aTmp)
        Ma = BoDau(aTmp(DD)):               Ma = Ma & BoDau(Left(aTmp(0), 1))
        Ma = Ma & IIf(DD = 1, "J", BoDau(Left(aTmp(DD - 1), 1)))
      
        Ma = Left(Ma & sNum, 9)
      
        Set Rng = .Range(.[D1], Cls.Offset(-1, 1))
        Set sRng = Rng.Find(Ma, , xlFormulas, xlPart)
        If sRng Is Nothing Then
            Cls.Offset(, 1).Value = Ma & "00"
        Else
            MyAdd = sRng.Address
            Do
                If CInt(Right(sRng.Value, 2)) > W Then W = CInt(Right(sRng.Value, 2))
                Set sRng = Rng.FindNext(sRng)
            Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
            Cls.Offset(, 1).Value = Ma & Right("0" & CStr(W + 1), 2)
            W = 0
        End If
    Next Cls
  End With
End Sub

Function BoDau(ByVal sContent As String) As String
Dim i As Long, intCode As Long
Dim sChar As String, sConvert As String

BoDau = AscW(sContent)
For i = 1 To Len(sContent)
    sChar = Mid(sContent, i, 1)
    If sChar <> "" Then
        intCode = AscW(sChar)
    End If
    Select Case intCode
    Case 273:           sConvert = sConvert & "f"  '
    Case 272
        sConvert = sConvert & "F"
    Case 224, 225, 226, 227, 259, 7841, 7843, 7845, 7847, 7849, 7851, 7853, 7855, 7857, 7859, 7861, 7863   ''
        sConvert = sConvert & "a"  ''
    Case 192, 193, 194, 195, 258, 7840, 7842, 7844, 7846, 7848, 7850, 7852, 7854, 7856, 7858, 7860, 7862
        sConvert = sConvert & "A"
    Case 232, 233, 234, 7865, 7867, 7869, 7871, 7873, 7875, 7877, 7879 ''
        sConvert = sConvert & "e"  ''
    Case 200, 201, 202, 7864, 7866, 7868, 7870, 7872, 7874, 7876, 7878
        sConvert = sConvert & "E"
    Case 236, 237, 297, 7881, 7883:         sConvert = sConvert & "i"  ''
    Case 204, 205, 296, 7880, 7882
        sConvert = sConvert & "I"
    Case 242, 243, 244, 245, 417, 7885, 7887, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907   ''
        sConvert = sConvert & "o"  ''
    Case 210, 211, 212, 213, 416, 7884, 7886, 7888, 7890, 7892, 7894, 7896, 7898, 7900, 7902, 7904, 7906
        sConvert = sConvert & "O"
    Case 249, 250, 361, 432, 7909, 7911, 7913, 7915, 7917, 7919, 7921:        sConvert = sConvert & "u"  ''
    Case 217, 218, 360, 431, 7908, 7910, 7912, 7914, 7916, 7918, 7920
        sConvert = sConvert & "U"
    Case 253, 7923, 7925, 7927, 7929
        sConvert = sConvert & "y"
    Case 221, 7922, 7924, 7926, 7928
        sConvert = sConvert & "Y"
    Case Else
        sConvert = sConvert & sChar
    End Select
 Next i
 BoDau = sConvert
End Function

]