Блог

Главная - Вопросы по программированию - Указатели ссылок VBA группируются по префиксу, используя фильтр, но сталкиваются с проблемой

Указатели ссылок VBA группируются по префиксу, используя фильтр, но сталкиваются с проблемой

#vba #ms-access

#vba #ms-access

Вопрос:

Вот мой код. Я беру следующие обозначения и сокращаю их до 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 amp; "-" amp; x(j) amp; prev 'close out current range with previous item
                    inRange = False
                End If
                s = s amp; IIf(Len(s) > 0, ",", "") amp; x(j) amp; v  'add the current item
            End If
            prev = v
        Next n
        If inRange Then s = s amp; "-" amp; x(j) amp; 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 amp; 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

Комментарии:

1. «для точного сопоставления символов или чего-то еще» — это что-то совершенно непонятное. По крайней мере, для меня… Вы ожидаете, что мы выведем из вашего кода, который «сталкивается с проблемой», то, что вы действительно хотите выполнить? Никому не нравится тратить свое время на такую деятельность… Я бы посоветовал вам отредактировать вопрос и попытаться точно объяснить, что вы пытаетесь сделать, в сравнении с тем, что вы получаете.

2. Вы пытаетесь перегруппировать смежные диапазоны в одном и том же диапазоне? Вы можете сделать это с помощью объединения: Set r = Range("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"): Set r = Union(r, r): Debug.Print r.Address(False, False) вернет AR15,AR2:AR4,AT3:AT4,C316,C319,C68,C76,FL14:FL18,FL6,J1:J6,L2:L5,T4:T6,U38

3. Код работает нормально, удаляя префикс с оставшимися числами. Например, когда применяется фильтр «AR», он найдет только ссылки с AR, в данном случае AR15, AR2, AR3, AR4. Затем он удаляет AR и возвращает числа, которые попадают в пузырьковую сортировку, так что из пузырьковой сортировки получается 2,3,4,15. Затем он возвращается к основной программе для диапазонов, в данном случае 2,3,4, и снова включает префикс AR и показывает AR2-AR4, а затем, поскольку 15 само по себе является AR15. Таким образом, общая возвращаемая строка равна AR2-AR4, AR5. Все в порядке с фильтром до «L». Поскольку «L» находится в «FL», он возвращается…

4. это тоже, и мне нужен способ, чтобы он различал префикс L от префикса FL.

5. Filter редко бывает настолько полезным, потому что он всегда фильтрует по подстрокам. Вы должны написать функцию, которая будет фильтровать по префиксу и возвращать массив только из этих типов совпадений.

Ответ №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," amp; _
          "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: " amp; Join(allPrefixes, ",")
    
    'process each prefix in turn
    For Each prefix In allPrefixes
    
        arrFilt = FilterPrefixNumbers(arr, prefix)        'items for this prefix (numbers only)
        Debug.Print , "'" amp; prefix amp; "' items:", Join(arrFilt, ",")
        arrSorted = ArraySort(arrFilt)                    'numeric parts, sorted ascending
        Debug.Print , "Sorted:", Join(arrSorted, ",")
        
        s = s amp; iif(s<>"", ",", "") amp; 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 amp; "-" amp; prefix amp; prev   'close out current range with previous item
                inRange = False
            End If
            s = s amp; IIf(Len(s) > 0, ",", "") amp; prefix amp; v  'add the current item
        End If
        prev = v
    Next n
    If inRange Then s = s amp; "-" amp; prefix amp; 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 amp; c
        End If
    Next i
    GetPrefix = rv
End Function

Комментарии:

1. Тим, это отлично работает. Единственное, что мне нужно, это чтобы все это возвращалось в одну строку. Я пытался, но это выглядит не так хорошо, как те, у которых один общий префикс.

2. См. Мою правку выше — собрать все это вместе не так уж и сложно.

3. Спасибо за помощь. возможно, это не скачок для вас, но это для меня. Я изучаю то, что вы сделали, поэтому в следующий раз мне не нужно задавать так много вопросов.

4. Тим, не заданный вопрос, могут ли ключи словаря выводиться в запрос в access, например, по 1 строке на ключ. Не могу ничего найти на нем.

5. Не уверен, что именно вы спрашиваете — вы говорите о вставке данных или запросе?

Ответ №2:

Устраните функции Filter() и Replace() . Учитывая, что входные данные уже отсортированы в алфавитном порядке по префиксу, работает следующая пересмотренная процедура:

 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) amp; "*" And i <= UBound(arr)
            If arr(i) Like x(j) amp; "*" Then
                s = s amp; Mid(arr(i), Len(x(j))   1) amp; ","
                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 amp; "-" amp; x(j) amp; prev 'close out current range with previous item
                    inRange = False
                End If
                s = s amp; IIf(Len(s) > 0, ",", "") amp; x(j) amp; v  'add the current item
            End If
            prev = v
        Next n
        If inRange Then s = s amp; "-" amp; x(j) amp; prev 'close out last item if in a range
        Debug.Print s
        s = Empty
        filterarray = Empty
    Next j
End Sub