VBA引用设计器按前缀分组，使用筛选器，但遇到问题

Question

这是我的密码。我采取下列指标，并缩短了他们分组到AR2-AR4，AR15，AT3-AT4，C68，C76，C316，C319，FL14-FL18，J1-J6，L2-5等。这都是好的，除非过滤器应用"L“返回FL14，FL15，FL16，FL17，FL8，L2，L3，L4，L5等。我需要一种方法来做一个精确的字符匹配或什么的。

Sub FormatAsRanges()
    
        Dim Lne As String, arr, s
        Dim n As Long, v As Long, prev As Long, inRange As Boolean
        Dim test As String
        Dim x As Variant
        Dim filterarray As Variant
        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 = Prefix(arr) 'Get the Prefix's (AR,AT,C,FL,J,L,T,U)
        x = Split(x, ",") ' Split them in an array
        
    For j = 0 To UBound(x)
    
        inRange = False 'Initialize to False
        arr = Split(Lne, ",") ' Redifine arr since it is being filtered and use in the j loop for each prefix
        filterarray = Filter(arr, x(j)) ' Apply filter
        For i = 0 To UBound(filterarray)
              filterarray(i) = Replace(filterarray(i), x(j), "")
        Next i
        arr = ArraySort(filterarray)
        prev = -999 'dummy value
        For n = LBound(filterarray) To UBound(filterarray)
            v = CLng(filterarray(n))
            If v - prev = 1 Then 'starting or continuing a range?
                inRange = True   'wait until range ends before adding anything
            Else
                If inRange Then           'ending a range ?
                    s = s & "-" & x(j) & prev 'close out current range with previous item
                    inRange = False
                End If
                s = s & IIf(Len(s) > 0, ",", "") & x(j) & v  'add the current item
            End If
            prev = v
        Next n
        If inRange Then s = s & "-" & x(j) & prev 'close out last item if in a range
        
        Debug.Print s
        s = Empty
        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 the character prefix (up to the first digit)
Public Function Prefix(a As Variant)
        Dim rv As String, c As String, i As Long, j As Long, k As Integer, Prf As String
        Dim flt(10) As String
        
    Prf = "*" 'Initialize string
    k = 0 'initialize
       
            For j = 0 To UBound(a)
             If InStr(a(j), Prf) Then
                
                'Debug.Print "Yes"
               
              Else
                   
                Prf = Empty
                For i = 0 To Len(a(j))
           
                    c = Mid(a(j), i + 1, 1)
                    If c Like "#" Then
                    
                    Exit For
                    
                    Else
                        rv = rv & c
                
              End If
            
            
            Next i
          Prf = rv
       
       flt(k) = Prf
       k = k + 1
       rv = Empty
       End If
        
    
    Next j
    
    For l = 0 To UBound(flt) 'Output as string so to define an array that is the correct size in the main program
      If flt(l) Like "?" Then
             rtn = rtn + flt(l) + ","
        ElseIf flt(l) Like "??" Then
             rtn = rtn + flt(l) + ","
            ElseIf flt(l) Like "???" Then
            
                    rtn = rtn + flt(l) + ","
          
        End If
            
    Next l
    rtn = Left(rtn, Len(rtn) - 1)
    Prefix = rtn
End Function

Answer 1

您可以将更多代码移动到单独的方法中：

Sub Tester()
    
    Dim Lne As String, arr, allPrefixes, arrFilt, arrSorted, s, prefix
    
    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, ",")        'split to an array
    
    allPrefixes = UniquePrefixes(arr) 'All unique character prefixes
    Debug.Print "All prefixes: " & Join(allPrefixes, ",")
    
    'process each prefix in turn
    For Each prefix In allPrefixes
    
        arrFilt = FilterPrefixNumbers(arr, prefix)        'items for this prefix (numbers only)
        Debug.Print , "'" & prefix & "' items:", Join(arrFilt, ",")
        arrSorted = ArraySort(arrFilt)                    'numeric parts, sorted ascending
        Debug.Print , "Sorted:", Join(arrSorted, ",")
        
        s = s & iif(s<>"", ",", "") & FormatAsRanges(arrSorted, prefix)
        'Debug.Print FormatAsRanges(arrSorted, prefix)
    
    Next prefix

    Debug.Print s 'the whole thing
End Sub
    
Function FormatAsRanges(arr, prefix) As String

    Dim s As String, n As Long, v As Long, prev As Long, inRange As Boolean

    prev = -999 'dummy value
    For n = LBound(arr) To UBound(arr)
        v = CLng(arr(n))
        If v - prev = 1 Then 'starting or continuing a range?
            inRange = True   'wait until range ends before adding anything
        Else
            If inRange Then           'ending a range ?
                s = s & "-" & prefix & prev   'close out current range with previous item
                inRange = False
            End If
            s = s & IIf(Len(s) > 0, ",", "") & prefix & v  'add the current item
        End If
        prev = v
    Next n
    If inRange Then s = s & "-" & prefix & prev 'close out last item if in a range
    
    FormatAsRanges = s
End Function


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
    
'return an array *of numbers* from all items in "arr" with the given prefix
Function FilterPrefixNumbers(arr, prefix)
    Dim rv(), e, n As Long
    ReDim rv(LBound(arr) To UBound(arr))
    n = LBound(arr)
    For Each e In arr
        If GetPrefix(CStr(e)) = prefix Then
            rv(n) = Replace(e, prefix, "") 'return just the numeric parts...
            n = n + 1
        End If
    Next e
    ReDim Preserve rv(LBound(arr) To n - 1) 'shrink to remove any empty slots
    FilterPrefixNumbers = rv
End Function

'all unique character prefixes
Function UniquePrefixes(arr)
    Dim dict, e
    Set dict = CreateObject("scripting.dictionary")
    For Each e In arr
        dict(GetPrefix(CStr(e))) = True
    Next e
    UniquePrefixes = dict.keys
End Function

'get the character prefix (all non-digit characters preceding the first digit)
Function GetPrefix(v As String) As String
    Dim rv As String, c As String, i As Long
    For i = 1 To Len(v)
        c = Mid(v, i, 1)
        If c Like "#" Then
            Exit For
        Else
            rv = rv & c
        End If
    Next i
    GetPrefix = rv
End Function

Answer 2

消除Filter()函数并替换()函数。考虑到输入数据已经按前缀按字母顺序排序，按照修订后的过程进行：

Sub FormatAsRanges()
    
    Dim Lne As String, arr, s
    Dim n As Long, v As Long, prev As Long 
    Dim inRange As Boolean
    Dim j As Integer, i As Integer
    Dim x As Variant
    Dim filterarray As Variant

    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 the Prefix's (AR,AT,C,FL,J,L,T,U)
        
    For j = 0 To UBound(x)
        inRange = False 'Initialize to False
        Do While arr(i) Like x(j) & "*" And i <= UBound(arr)
            If arr(i) Like x(j) & "*" Then
                s = s & Mid(arr(i), Len(x(j)) + 1) & ","
                If i = UBound(arr) Then
                    Exit Do
                Else
                    i = i + 1
                End If
            End If
        Loop
        If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)
        filterarray = ArraySort(Split(s, ","))
        prev = -999 'dummy value
        s = ""
        For n = LBound(filterarray) To UBound(filterarray)
            v = CLng(filterarray(n))
            If v - prev = 1 Then 'starting or continuing a range?
                inRange = True   'wait until range ends before adding anything
            Else
                If inRange Then           'ending a range ?
                    s = s & "-" & x(j) & prev 'close out current range with previous item
                    inRange = False
                End If
                s = s & IIf(Len(s) > 0, ",", "") & x(j) & v  'add the current item
            End If
            prev = v
        Next n
        If inRange Then s = s & "-" & x(j) & prev 'close out last item if in a range
        Debug.Print s
        s = Empty
        filterarray = Empty
    Next j
End Sub