Tặng Hàm đặt mã nhân viên theo họ tên (tên viết tắt + 1 dãy số)

[Hoàng Trọng Nghĩa]

Thông thường các công ty luôn lấy số thứ tự định dạng kiểu "00000" làm mã số, cũng có một số nơi lấy tên tắt đầu của công ty rồi gán số thứ tự làm mã, ví dụ Cảng Sài Gòn ==> Mã NV: CSG000001, cũng vậy, có một số công ty lấy họ tên (viết tắt) hoặc lấy theo khối phòng ban (viết tắt) thêm 1 loạt dãy số nữa làm mã nhân viên, ví dụ Hoàng Trọng Nghĩa, MS: HTN000001 hoặc Đội Kho Hàng: DKH000001.


Nếu như chỉ lấy số thứ tự thôi thì có gì phải bàn, riêng các trường hợp sau, rất khó cho chúng ta đặt mã, vì làm sao nhận biết được có trùng tên không, trùng tên thì có trùng số hay không, làm sao thêm 1 vào dãy số phía sau nếu bị trùng?

Trước đây có bài tại đường link dưới rất hay, nhưng tôi vẫn chưa cảm thấy ổn vì còn hạn chế nhiều thứ.
Xem tại đây: http://www.giaiphapexcel.com/forum/...i-họ-tên-tiếng-Việt-để-làm-mã-nhân-viên/page5

Nay tôi viết ra hàm này để mọi người cùng tham khảo, ứng dụng hoặc cải tiến nếu có thể.

Như bài này, tôi cần có 2 hàm hỗ trợ, đó là hàm loại dấu tiếng việt FontConverter (UNI / VNI), và hàm hỗ trợ còn lại là hàm họ tên viết tắt InitialName:

Function InitialName(UniOrVniText As String, ByVal SourceCode As Byte) As String[COLOR=#006400]    'SourceCode: 1 is Unicode; 2 is VNI Windows[/COLOR]
    UniOrVniText = Replace(Trim(UniOrVniText), "0", "")
    If Len(UniOrVniText) = 0 Then InitialName = "": Exit Function
    If InStr(UniOrVniText, " ") = 0 Then
        If Len(UniOrVniText) < 4 Then InitialName = UniOrVniText Else InitialName = Left(UniOrVniText, 3)
    Else
        UniOrVniText = " " & UniOrVniText
            Do Until InStr(UniOrVniText, " ") = 0
                UniOrVniText = Mid(UniOrVniText, InStr(UniOrVniText, " ") + 1, Len(UniOrVniText))
                InitialName = InitialName & Left(UniOrVniText, 1)
            Loop
        InitialName = UCase(FontConverter(InitialName, SourceCode, 3))
    End If
End Function

Khi đã có 2 hàm trên, việc viết hàm chính đã là chuyện dễ dàng!

Hàm đặt mã theo họ tên hoặc đơn vị: IDMaxPlus

Function IDMaxPlus(ByVal SrcRng, ByVal UniOrVniText, ByVal SourceCode As Byte) As String
    Dim i As Long, j As Long, Tmp As Long, TmpMax As Long
    Dim LenKeyText As Long, KeyText As String, Arr
    On Error Resume Next
    KeyText = UniOrVniText
    KeyText = InitialName(KeyText, SourceCode)
    LenKeyText = Len(KeyText): TmpMax = 0
    Arr = SrcRng.Value
    If Not IsArray(Arr) Then
        If Left(SrcRng.Value, LenKeyText) = KeyText Then
            TmpMax = CLng(Right(SrcRng.Value, Len(SrcRng.Value) - LenKeyText))
        End If
    Else
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                If Left(Arr(i, j), LenKeyText) = KeyText Then
                    Tmp = CLng(Right(Arr(i, j), Len(Arr(i, j)) - LenKeyText))
                    If TmpMax < Tmp Then TmpMax = Tmp
                End If
            Next
        Next
    End If
    IDMaxPlus = KeyText & Format(TmpMax + 1, "00000")
End Function

Cách sử dụng hàm IDMaxPlus:

=IDMaxPlus(VungSoSanh,HoTen,MaNguon)

Với MaNguon (mã nguồn):

1 là mã Unicode; 2 là mà VNI Windows

Các bạn xem file nhé!

==============================================
Vì lý do chỉnh sửa, xin các bạn xem file tại bài 2 của topic này:
http://www.giaiphapexcel.com/forum/...n-(tên-viết-tắt-1-dãy-số)&p=393458#post393458

 

[Hoàng Trọng Nghĩa]

Sau khi post bài lên, thấy còn "sạn" trong hàm, giờ xin gửi lại hàm đã được chỉnh sửa:

Thay vì bắt buộc lựa chọn SourceCode:

Function InitialName(UniOrVniText As String, [B][COLOR=#ff0000]ByVal [/COLOR]SourceCode As Byte[/B]) As String


Function IDMaxPlus(ByVal SrcRng, ByVal UniOrVniText, [B][COLOR=#ff0000]ByVal [/COLOR]SourceCode As Byte[/B]) As String

thì chỉ chọn lựa có hay không cũng tùy vào mã nguồn:

Function InitialName(ByVal UniOrVniText As String, [B][COLOR=#0000cd]Optional [/COLOR]SourceCode As Byte[/B]) As String

Function IDMaxPlus(ByVal SrcRng, ByVal UniOrVniText, [B][COLOR=#0000cd]Optional [/COLOR]SourceCode As Byte[/B]) As String

Nếu không dấu tiếng Việt thì ta không cần phải thêm SourceCode.

Hàm trước tự dưng mình nghĩ phải có đoạn này:

UniOrVniText = Replace(Trim(UniOrVniText), "0", "")

Giờ nâng cấp bản mới như sau:

Hàm viết tắt tên:

Function InitialName(ByVal UniOrVniText As String, Optional SourceCode As Byte) As String
[COLOR=#006400]    'If UniOrVniText is NonDiacritic then the function no need any SourceCode (for faster)
    'SourceCode: 1 is Unicode; 2 is VNI Windows[/COLOR]
    UniOrVniText = Trim(UniOrVniText)
    If Len(UniOrVniText) = 0 Then InitialName = "": Exit Function
    
    If InStr(UniOrVniText, " ") = 0 Then
        If SourceCode = 1 Or SourceCode = 2 Then UniOrVniText = FontConverter(UniOrVniText, SourceCode, 3)
        If Len(UniOrVniText) < 4 Then InitialName = UniOrVniText Else InitialName = Left(UniOrVniText, 4)
    Else
        UniOrVniText = " " & UniOrVniText
        Do Until InStr(UniOrVniText, " ") = 0
            UniOrVniText = Mid(UniOrVniText, InStr(UniOrVniText, " ") + 1, Len(UniOrVniText))
            InitialName = InitialName & Left(UniOrVniText, 1)
        Loop
        If SourceCode = 1 Or SourceCode = 2 Then InitialName = FontConverter(InitialName, SourceCode, 3)
    End If
    
    InitialName = UCase(InitialName)
End Function

Và hàm chính Đặt mã theo tên được cải tiến như sau:

Function IDMaxPlus(ByVal SrcRng, ByVal UniOrVniText, Optional SourceCode As Byte) As String
[COLOR=#006400]    'If UniOrVniText is NonDiacritic then the function no need any SourceCode (for faster)
    'SourceCode: 1 is Unicode; 2 is VNI Windows[/COLOR]
    Dim i As Long, j As Long, TmpMax As Long, Tmp As Long
    Dim KeyText As String, LenKeyText As Long, Arr
    On Error Resume Next
    Arr = SrcRng: Arr = Arr.Value
    KeyText = UniOrVniText
    KeyText = InitialName(KeyText, SourceCode)
    LenKeyText = Len(KeyText): TmpMax = 0
    If Not IsArray(Arr) Then
        If Left(UCase(Arr), LenKeyText) = KeyText Then
            TmpMax = Right(Arr, Len(Arr) - LenKeyText)
        End If
    Else
        For i = 1 To UBound(Arr, 1)
            For j = 1 To UBound(Arr, 2)
                If Left(UCase(Arr(i, j)), LenKeyText) = KeyText Then
                    Tmp = Right(Arr(i, j), Len(Arr(i, j)) - LenKeyText)
                    If TmpMax < Tmp Then TmpMax = Tmp
                End If
            Next
        Next
    End If
    IDMaxPlus = KeyText & Format(TmpMax + 1, "00000")
End Function

Hy vọng hàm này giúp ích được cho các bạn.

 

[Hoàng Trọng Nghĩa]

Tặng hàm tìm số thứ tự, mã số bị thiếu trong dãy số thứ tự.

Những ngày qua tôi trăn trở và nghĩ một số bạn cũng như tôi không biết giải quyết thế nào để tìm nhanh mã số bị thiếu trong dãy số thứ tự, thì hôm nay tôi cũng tặng các bạn giải pháp dùng hàm mảng để tìm trong vùng bị cho là số thứ tự bị thiếu, để tìm ra những số thiếu đó.

Hàm Tìm số bị thiếu:

Function FindIDMissing(ByVal NumMin As Double, _
                       ByVal NumMax As Double, _
                       Optional SrcRng As Variant, _
                       Optional KeyText As String) As Variant
[COLOR=#006400]    'FindIDMissing(SoNhoNhat,SoLonNhat,[VungDuLieu],[KyTuDau])
    'On Error Resume Next[/COLOR]
    If Abs(NumMin - NumMax) <= 1 Then FindIDMissing = "": Exit Function
    Dim i As Long, j As Long, k As Long, n As Long, Chk As Boolean, sArray, MyArr
    Dim iMin As Double, iMax As Double, KeyItem As String, KeyLen As Long
    If NumMin + 1 > NumMax - 1 Then
        iMin = NumMax - 1: iMax = NumMin + 1
    Else
        iMin = NumMin + 1: iMax = NumMax - 1
    End If
    KeyText = UCase(KeyText): KeyLen = Len(KeyText)
    If iMin = iMax Then
        If KeyLen = 0 Then
            FindIDMissing = NumMax - NumMin + 1: Exit Function
        Else
[COLOR=#006400][B]            'FORMAT HAY KHONG, TUY BAN![/B][/COLOR]
            FindIDMissing = KeyText & Format(i, "00000"): Exit Function
        End If
    End If
    ReDim sArray(1 To iMax, 1 To 1): n = 0
    If Not IsArray(SrcRng) Then
        If KeyLen = 0 Then
            For i = iMin To iMax
                n = n + 1
                sArray(n, 1) = i
            Next
        Else
            For i = iMin To iMax
                n = n + 1
                sArray(n, 1) = KeyText & Format(i, "00000")
            Next
        End If
    Else
        If KeyLen = 0 Then
            For i = iMin To iMax
                For j = 1 To UBound(SrcRng, 1)
                    For k = 1 To UBound(SrcRng, 2)
                        KeyItem = SrcRng(j, k)
                        If KeyItem <> "" Then
                            If Val(KeyItem) = i Then Chk = False: GoTo NextI Else Chk = True
                        End If
                    Next
                Next
NextI:
                If Chk Then n = n + 1: sArray(n, 1) = i
            Next
        Else
            For i = iMin To iMax
                For j = 1 To UBound(SrcRng, 1)
                    For k = 1 To UBound(SrcRng, 2)
                        KeyItem = UCase(SrcRng(j, k))
                        If KeyItem <> "" And Len(KeyItem) > KeyLen Then
                            If Left(KeyItem, KeyLen) = KeyText And Right(KeyItem, Len(KeyItem) - KeyLen) = i Then
                                Chk = False: GoTo NextII
                            Else
                                Chk = True
                            End If
                        End If
                    Next
                Next
NextII:
                If Chk Then n = n + 1: sArray(n, 1) = KeyText & Format(i, "00000")
            Next
        End If
    End If
    ReDim MyArr(1 To n, 1 To 1)
        For i = 1 To n
            MyArr(i, 1) = sArray(i, 1)
        Next
    FindIDMissing = MyArr
    Erase sArray, MyArr
End Function

Nói là hàm tìm số thứ tự bị thiếu, nhưng nó có thêm các tiện ích như tạo 1 cột số thứ tự cho trước, ví dụ muốn có cột giá trị từ 1 đến 100 ta chỉ cần:

Sub KiemTra()
    [COLOR=#0000cd][B]Arr = FindIDMissing(0, 101)[/B][/COLOR]
    Sheet1.[Q1].Resize(UBound(Arr)).Value = Arr
End Sub

Nếu muốn đặt Cột có chuỗi kèm theo số, ta chỉ thêm cái đầu chữ vào, ví dụ muốn tạo cột có đầu là HTN từ 1 đến 100 (kết quả HTN00001 đến HTN00100) thì ta làm thủ tục như sau:

Sub KiemTra4()
   [B][COLOR=#0000cd] Arr = FindIDMissing(0, 101, , "HTN")[/COLOR][/B]
    Sheet1.[S1].Resize(UBound(Arr)).Value = Arr
End Sub

Và dĩ nhiên, mục đích chính của hàm này là tìm ra dãy số có số bị thiếu:

Sub KiemTra3()
    SrcRng = Sheet1.[B1:D20].Value
    [COLOR=#0000cd][B]Arr = FindIDMissing(3, 35, SrcRng)[/B][/COLOR]
    If IsArray(Arr) Then
        Sheet1.[O1].Resize(UBound(Arr)).Value = Arr
    Else
        Sheet1.[O1].Value = Arr
    End If
End Sub

Hoặc tìm kiếm số có chữ bị thiếu:

Sub KiemTra1()
    SrcRng = Sheet1.[E1:G20].Value
   [B][COLOR=#0000cd] Arr = FindIDMissing(3, 35, SrcRng, "HTN")[/COLOR][/B]
    If IsArray(Arr) Then
        Sheet1.[K1].Resize(UBound(Arr)).Value = Arr
    Else
        Sheet1.[K1].Value = Arr
    End If
End Sub

Với hàm này, tại Topic có đường link dưới đây được giải quyết như sau:
http://www.giaiphapexcel.com/forum/...ông-liên-tục-trong-dãy-số&p=140280#post140280

Mình có một bảng kê số hóa đơn đã phát hành trong năm, vì số lượng hóa đơn phát hành quá nhiều và số hủy cũng nhiều, nên khi quyết toán thì không thể nhớ được là mình đã hủy bao nhiêu số hóa đơn. Nếu ngồi đếm bằng tay hoặc đếm từng số hóa đơn trên Excel thì phê quá, mà kết quả thì không thể chắc chắn đúng đến mức tối thiểu.

Trên đây là file dữ liệu nhỏ, Bảng dữ liểu đầy đủ cả 50.000 cái hóa đơn, mà tìm bằng tay thì mỏi cả mắt. Mong mọi người giúp mình cái này.

Với bài này, thì hàm tìm số thiếu sẽ dễ dàng cho bạn phát hiện ra số thiếu:

Sub TestSoThieu()
    Dim sArr, Arr, MyRng As Range, i As Long, k As Long
    With Sheet1
        .Range("I:L").ClearContents
        sArr = Range(.[D4], .[D65536].End(xlUp)).Value
        Set MyRng = Sheet1.[F4:H7]
        k = MyRng.Rows.Count
        For i = 1 To k
            Arr = FindIDMissing(MyRng(i, 2).Value, MyRng(i, 3).Value, sArr)
            .[I3].Offset(, i - 1).Value = MyRng(i, 1).Value
            .[I4].Offset(, i - 1).Resize(UBound(Arr)).Value = Arr
        Next
    End With
    Set MyRng = Nothing: Erase sArr
End Sub

Các bạn xem file của bài mà cô bạn này gửi và file ví dụ tôi gửi lên. Hy vọng sẽ giúp ích cho các bạn.