VBA按前缀分组元器件位号时L前缀筛选匹配错误的技术问题

The core issue here is that VBA's built-in Filter function does a partial substring match by default. When filtering for the prefix L, it grabs any designator that contains L anywhere in the string—hence why FL14 through FL18 get included alongside L2-L5. We need to replace this with an exact prefix check to only keep items where the prefix is the leading part of the designator.

Modified VBA Code #

Here's the updated code with precise prefix matching, plus some cleanups for robustness:

Sub FormatAsRanges()
    Dim Lne As String, arr, s
    Dim n As Long, v As Long, prev As Long, inRange As Boolean
    Dim x As Variant
    Dim filterarray As Variant
    Dim i As Long, j As Long
    
    inRange = False
    Lne = "AR15,AR2,AR3,AR4,AT3,AT4,C316,C319,C68,C76,FL14,FL15,FL16,FL17,FL18,FL6,J1,J2,J3,J4,J5,J6,L2,L3,L4,L5,T4,T5,T6,U38"
    arr = Split(Lne, ",") 'Break apart references into array items
    x = Split(Prefix(arr), ",") ' Get unique prefixes as array
    
    For j = 0 To UBound(x)
        inRange = False
        prev = -999 'dummy initial value
        s = ""
        
        ' --- KEY FIX: Exact prefix matching instead of partial Filter ---
        ' Build filterarray manually with exact prefix matches
        ReDim filterarray(0 To 0)
        For i = 0 To UBound(arr)
            ' Check if designator starts with the prefix, followed by a digit (matches our component pattern)
            If arr(i) Like x(j) & "#*" Or arr(i) = x(j) Then
                ' Add numeric suffix to filterarray
                filterarray(UBound(filterarray)) = Replace(arr(i), x(j), "")
                ReDim Preserve filterarray(0 To UBound(filterarray) + 1)
            End If
        Next i
        ' Remove empty last element from dynamic array
        If UBound(filterarray) > 0 Then
            ReDim Preserve filterarray(0 To UBound(filterarray) - 1)
        Else
            ' No matches for this prefix, skip to next
            GoTo NextPrefix
        End If
        ' --- End of key fix ---
        
        ' Sort the numeric suffixes
        filterarray = ArraySort(filterarray)
        
        ' Build the range-formatted string
        For n = LBound(filterarray) To UBound(filterarray)
            v = CLng(filterarray(n))
            If v - prev = 1 Then
                inRange = True
            Else
                If inRange Then
                    s = s & "-" & x(j) & prev
                    inRange = False
                End If
                s = s & IIf(Len(s) > 0, ",", "") & x(j) & v
            End If
            prev = v
        Next n
        
        ' Close out any open range
        If inRange Then
            s = s & "-" & x(j) & prev
        End If
        
        Debug.Print s
NextPrefix:
        filterarray = Empty
    Next j
End Sub

Function ArraySort(MyArray As Variant)
    Dim First As Long, last As Long
    Dim i As Long, j As Long, Temp
    First = LBound(MyArray)
    last = UBound(MyArray)
    For i = First To last - 1
        For j = i + 1 To last
            If CLng(MyArray(i)) > CLng(MyArray(j)) Then
                Temp = MyArray(j)
                MyArray(j) = MyArray(i)
                MyArray(i) = Temp
            End If
        Next j
    Next i
    ArraySort = MyArray
End Function

' Get unique character prefixes (up to the first digit)
Public Function Prefix(a As Variant)
    Dim rv As String, c As String, i As Long, j As Long
    Dim prefixes As Collection
    Set prefixes = New Collection
    
    ' Collect unique prefixes using a collection (auto-handles duplicates)
    On Error Resume Next
    For j = 0 To UBound(a)
        rv = ""
        For i = 0 To Len(a(j)) - 1
            c = Mid(a(j), i + 1, 1)
            If c Like "#" Then Exit For
            rv = rv & c
        Next i
        If rv <> "" Then
            prefixes.Add rv, Key:=rv ' Key ensures no duplicates
        End If
    Next j
    On Error GoTo 0
    
    ' Convert collection to comma-separated string
    rv = ""
    For i = 1 To prefixes.Count
        rv = rv & prefixes(i) & ","
    Next i
    If Len(rv) > 0 Then rv = Left(rv, Len(rv) - 1)
    Prefix = rv
End Function

Key Changes Explained #

1. Exact Prefix Matching:

   • Replaced the Filter(arr, x(j)) call with a manual loop using the Like operator: arr(i) Like x(j) & "#*"
   • This checks that the designator starts with the target prefix and is immediately followed by a digit, which aligns with standard component designator formatting.

2. Robust Prefix Collection:

   • Rewrote the Prefix function to use a Collection with keys, which automatically removes duplicate prefixes more cleanly than the original array-based approach.

3. Edge Case Handling:

   • Added checks to skip prefixes with no matches, and cleaned up dynamic array handling for filterarray to avoid empty elements that could cause errors.

Test Output #

When you run this code, the output for prefix L will correctly be:

L2-L5

And the FL prefix will output:

FL6,FL14-FL18

All other prefixes will continue to group ranges as expected.

内容的提问来源于stack exchange，提问作者Bryan Hildreth