Fatal编程技术网
  • vba/
  • VBA引用标识符按前缀分组，使用筛选器但遇到问题

VBA引用标识符按前缀分组，使用筛选器但遇到问题

vba ms-access

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,

这是我的密码。我使用以下指示符，并将它们分组为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
消除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) & "*" 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

子格式asranges（）
作为字符串的暗Lne，arr，s
变暗n为长，v为长，上一个为长
Dim inRange作为布尔值
Dim j为整数，i为整数
Dim x作为变体
作为变体的Dim Filterray
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=拆分（Lne，“，”）将引用拆分为数组项
x=Split（前缀（arr），“，”）获取前缀（AR，AT，C，FL，J，L，T，U）
对于j=0到UBound（x）
inRange=False'初始化为False

当arr（i）如x（j）&“*”和i时，您可以将更多代码移动到单独的方法中：


子测试仪（）
将Lne设置为字符串、arr、所有前缀、arrFilt、arrSorted、s、前缀
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=拆分（Lne，“，”）到阵列
allPrefixes=唯一前缀（arr）'所有唯一字符前缀
调试。打印“所有前缀：”&Join（所有前缀，“，”）
'依次处理每个前缀
对于所有前缀中的每个前缀
arrFilt=FilterPrefixNumbers（arr，前缀）'此前缀的项目（仅限数字）
Debug.Print，“'”&前缀和“'items:”，连接（arrFilt，”，“”）
arrsorded=ArraySort（arrFilt）'数字部分，升序排序
Debug.Print，“排序：”，Join（arrsorded，”，“”）
s=s&iif（s“”、“”、“”）和FormatAsRanges（arrSorted，前缀）
'Debug.Print FormatAsRanges（arrsorded，前缀）
下一个前缀
调试，打印，这就是全部
端接头
函数FormatAsRanges（arr，前缀）作为字符串
尺寸s为字符串，n为长，v为长，prev为长，inRange为布尔值
prev=-999'伪值
对于n=LBound（arr）至UBound（arr）
v=CLng（arr（n））
如果v-prev=1，则“开始或继续一个范围？”？
inRange=True“在添加任何内容之前，等待范围结束
其他的
如果在范围内，则“结束范围”？
s=s&“-”&前缀和上一项结束当前范围
inRange=False
如果结束
s=s&IIf（长度>0，“，”）&前缀&v'添加当前项
如果结束
prev=v
下一个
如果在范围内，则s=s&“-”&prefix&prev“关闭范围内的最后一项
FormatAsRanges=s
端函数
函数ArraySort（MyArray作为变量）
先变暗一样长，后变暗一样长
尺寸i等于长，j等于长，温度
First=LBound（MyArray）
last=UBound（MyArray）
对于i=从第一个到最后一个-1
对于j=i+1到最后
如果CLng（MyArray（i））>CLng（MyArray（j）），那么
温度=MyArray（j）
MyArray（j）=MyArray（i）
MyArray（i）=温度
如果结束
下一个j
接下来我
ArraySort=MyArray
端函数
'使用给定前缀从“arr”中的所有项返回数字*的数组*
函数filterPrefixNumber（arr，前缀）
尺寸rv（），e，n与长度相同
重拨房车（LBound（arr）至UBound（arr））
n=磅重（arr）
对于arr中的每个e
如果GetPrefix（CStr（e））=前缀，则
rv（n）=替换（e，前缀“”）只返回数字部分。。。
n=n+1
如果结束
下一个e
ReDim保留rv（LBound（arr）至n-1）收缩以移除任何空槽
FilterPrefixNumber=rv
端函数
'所有唯一字符前缀
函数唯一前缀（arr）
模糊词典
Set dict=CreateObject（“scripting.dictionary”）
对于arr中的每个e
dict（GetPrefix（CStr（e））=True
下一个e
唯一前缀=dict.keys
端函数
'获取字符前缀（第一个数字之前的所有非数字字符）
函数GetPrefix（v作为字符串）作为字符串
尺寸rv为字符串，c为字符串，i为长度
对于i=1到Len（v）
c=中间（v，i，1）
如果c喜欢“#”，那么
退出
其他的
rv=rv&c
如果结束
接下来我
GetPrefix=rv
端函数

“进行精确的字符匹配或其他什么”是完全不清楚的。至少，对我来说。。。您希望我们从您的代码中推断出您真正想要实现的“遇到问题”是什么吗？没有人喜欢在这样的活动上浪费时间。。。我建议你编辑这个问题，并试着根据你得到的信息准确地解释你想做什么。你想在同一范围内重新组合相邻的范围吗？您可以使用Union来执行此操作：
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、False）
将返回
AR15、AR2:AR4、AR4、AR4、AT3、C316、c38、c36、c36、j18、flt6、flt6、，U38
代码可以很好地去除前缀和剩余的数字。与应用过滤器“AR”时一样，在本例中，它将仅查找带有AR的引用AR15、AR2、AR3、AR4。然后它删除AR并返回进入冒泡排序的数字，因此冒泡排序结果为2,3,4,15。然后，它返回到主程序的范围，在本例中为2,3,4，并将前缀AR重新打开，显示AR2-AR4，然后由于15本身就是AR15。所以返回的总行是AR2-AR4，AR5。在f上一切都很好