[TẶNG] Hàm tìm ID còn thiếu sót (FindShortageID).

Liên hệ QC

Hoàng Trọng Nghĩa

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,662
Được thích
16,718
Giới tính
Nam
Nhân dịp có bài viết:


Tôi viết một hàm tìm ID còn sót trong dãy thứ tự của cột ID, hàm đơn giản, không cần dùng Dictionary các bạn tham khảo nhé.

Mã:
Function FindShortageID(ByVal rngSource, ByVal strChuoiKyTu As String, Optional ByVal bytKySo As Byte = 1) As Variant
    Dim bytLen As Byte
    Dim arrResult, arrSource, arrTemp(), arrTemple()
    Dim lngIDNum As Long, c As Long, i As Long, k As Long, n As Long, r As Long, lbd As Long, lbd2 As Long, ubd As Long
    bytLen = Len(strChuoiKyTu)
    If IsNumeric(rngSource) Or TypeName(rngSource) = "String" Then
        ReDim arrSource(1 To 1, 1 To 1)
        arrSource(1, 1) = rngSource
    ElseIf TypeName(rngSource) = "Range" Then
        If rngSource.Rows.Count = 1 And rngSource.Columns.Count = 1 Then
            ReDim arrSource(1 To 1, 1 To 1)
            arrSource(1, 1) = rngSource.Value
        Else
            arrSource = rngSource.Value
        End If
    ElseIf IsArray(rngSource) Then
        If GetArrDimensions(rngSource) = 1 Then
            arrSource = WorksheetFunction.Transpose(rngSource)
        Else
            arrSource = rngSource
        End If
    End If
   
    lbd = LBound(arrSource, 1): lbd2 = LBound(arrSource, 2)
    ubd = UBound(arrSource, 1)
   
    For i = lbd To ubd
        If Left(arrSource(i, lbd2), bytLen) = strChuoiKyTu Then
            n = n + 1
            ReDim Preserve arrTemp(1 To n)
            arrTemp(n) = Abs(Val(Replace(arrSource(i, lbd2), strChuoiKyTu, "")))
        End If
    Next
   
    If n Then
        ubd = WorksheetFunction.Max(arrTemp)
        For r = 1 To ubd
            For c = 1 To n
                If arrTemp(c) = r Then
                    GoTo NextNum
                End If
            Next
            k = k + 1
            ReDim Preserve arrTemple(1 To k)
            arrTemple(k) = strChuoiKyTu & Format(r, String(bytKySo, "0"))
NextNum:
        Next
        If k Then
            ReDim arrResult(1 To k + 1, 1 To 1)
            For r = 1 To k
                arrResult(r, 1) = arrTemple(r)
            Next
            arrResult(r, 1) = strChuoiKyTu & Format(ubd + 1, String(bytKySo, "0"))
        Else
            ReDim arrResult(1 To 1, 1 To 1)
            arrResult(1, 1) = strChuoiKyTu & Format(ubd + 1, String(bytKySo, "0"))
        End If
    Else
        ReDim arrResult(1 To 1, 1 To 1)
        arrResult(1, 1) = strChuoiKyTu & Format(1, String(bytKySo, "0"))
    End If
   
    FindShortageID = arrResult
   
End Function

Khuyến mãi thêm hàm nhận biết mảng có bao nhiêu chiều:

Mã:
Function GetArrDimensions(arrVariant) As Long
    Dim c As Long, n As Long
    On Error GoTo Result
    Do
        c = c + 1
        n = LBound(arrVariant, c)
    Loop
Result:
    GetArrDimensions = c - 1
End Function

Khi tôi viết hàm này tôi đã lường trước nhiều kiểu dữ liệu nhập vào nên nó khá tổng quát, ngoại trừ mảng xuất ra từ ADO (GetRows) vì nó ngược ngược với mảng từ Range của Excel, nhưng nếu chép mảng đó vào Excel thì xử lý vô tư.

Với file tôi đính kèm, đọc kỹ hướng dẫn trước khi sử dụng.

HƯỚNG DẪN SỬ DỤNG
1) Copy cột ID được cho là thiếu số thứ tự liên tục vào cột A
2) Điền vào ô F2 chuỗi tương ứng
3) Điền vào ô G2 số lượng ký số định dạng (VD: 001 là 3, 0001 là 4, 000001 là 6,…)
4) Bấm nút sẽ ra kết quả, hàm trả về dãy ID còn thiếu và 01 ID mới.
5) Kết quả nó sẽ sắp xếp ID từ nhỏ đến lớn cho bạn mặc dù cột A có lộn xộn.
 

File đính kèm

  • IDMaxNum.xlsm
    25.8 KB · Đọc: 41
Lần chỉnh sửa cuối:
Nhân dịp có bài viết:


Tôi viết một hàm tìm ID còn sót trong dãy thứ tự của cột ID, hàm đơn giản, không cần dùng Dictionary các bạn tham khảo nhé.

Mã:
Function FindShortageID(ByVal rngSource, ByVal strChuoiKyTu As String, Optional ByVal bytKySo As Byte = 1) As Variant
    Dim bytLen As Byte
    Dim arrResult, arrSource, arrTemp(), arrTemple()
    Dim lngIDNum As Long, c As Long, i As Long, k As Long, n As Long, r As Long, lbd As Long, lbd2 As Long, ubd As Long
    bytLen = Len(strChuoiKyTu)
    If IsNumeric(rngSource) Or TypeName(rngSource) = "String" Then
        ReDim arrSource(1 To 1, 1 To 1)
        arrSource(1, 1) = rngSource
    ElseIf TypeName(rngSource) = "Range" Then
        If rngSource.Rows.Count = 1 And rngSource.Columns.Count = 1 Then
            ReDim arrSource(1 To 1, 1 To 1)
            arrSource(1, 1) = rngSource.Value
        Else
            arrSource = rngSource.Value
        End If
    ElseIf IsArray(rngSource) Then
        If GetArrDimensions(rngSource) = 1 Then
            arrSource = WorksheetFunction.Transpose(rngSource)
        Else
            arrSource = rngSource
        End If
    End If
  
    lbd = LBound(arrSource, 1): lbd2 = LBound(arrSource, 2)
    ubd = UBound(arrSource, 1)
  
    For i = lbd To ubd
        If Left(arrSource(i, lbd2), bytLen) = strChuoiKyTu Then
            n = n + 1
            ReDim Preserve arrTemp(1 To n)
            arrTemp(n) = Abs(Val(Replace(arrSource(i, lbd2), strChuoiKyTu, "")))
        End If
    Next
  
    If n Then
        ubd = WorksheetFunction.Max(arrTemp)
        For r = 1 To ubd
            For c = 1 To n
                If arrTemp(c) = r Then
                    GoTo NextNum
                End If
            Next
            k = k + 1
            ReDim Preserve arrTemple(1 To k)
            arrTemple(k) = strChuoiKyTu & Format(r, String(bytKySo, "0"))
NextNum:
        Next
        If k Then
            ReDim arrResult(1 To k + 1, 1 To 1)
            For r = 1 To k
                arrResult(r, 1) = arrTemple(r)
            Next
            arrResult(r, 1) = strChuoiKyTu & Format(ubd + 1, String(bytKySo, "0"))
        Else
            ReDim arrResult(1 To 1, 1 To 1)
            arrResult(1, 1) = strChuoiKyTu & Format(ubd + 1, String(bytKySo, "0"))
        End If
    Else
        ReDim arrResult(1 To 1, 1 To 1)
        arrResult(1, 1) = strChuoiKyTu & Format(1, String(bytKySo, "0"))
    End If
  
    FindShortageID = arrResult
  
End Function

Khuyến mãi thêm hàm nhận biết mảng có bao nhiêu chiều:

Mã:
Function GetArrDimensions(arrVariant) As Long
    Dim c As Long, n As Long
    On Error GoTo Result
    Do
        c = c + 1
        n = LBound(arrVariant, c)
    Loop
Result:
    GetArrDimensions = c - 1
End Function

Khi tôi viết hàm này tôi đã lường trước nhiều kiểu dữ liệu nhập vào nên nó khá tổng quát, ngoại trừ mảng xuất ra từ ADO (GetRows) vì nó ngược ngược với mảng từ Range của Excel, nhưng nếu chép mảng đó vào Excel thì xử lý vô tư.

Với file tôi đính kèm, đọc kỹ hướng dẫn trước khi sử dụng.

HƯỚNG DẪN SỬ DỤNG
1) Copy cột ID được cho là thiếu số thứ tự liên tục vào cột A
2) Điền vào ô F2 chuỗi tương ứng
3) Điền vào ô G2 số lượng ký số định dạng (VD: 001 là 3, 0001 là 4, 000001 là 6,…)
4) Bấm nút sẽ ra kết quả, hàm trả về dãy ID còn thiếu và 01 ID mới.
5) Kết quả nó sẽ sắp xếp ID từ nhỏ đến lớn cho bạn mặc dù cột A có lộn xộn.
Cảm ơn anh 1 Ứng dụng hữu ích
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom