字符串的筛选

yhy95331

从000到666中筛选符合条件的字符串并用空格连接起来，条件是：必须包含A列字符串，如：001 002  003 。。。包含00 视为选中，112 121 123....包含12视为选中，代码不知哪里出问题，结果不符，请高手看一下，谢谢


Sub Strselect()
Dim i As Integer, ii As Integer, dx As String, dz As String, d0 As String, t As String

Arr = [A2:A7]
    For i = 1 To UBound(Arr)
         x = Split(Arr(i, 1), " ")
             For ii = LBound(x) To UBound(x)
              t = x(ii)
               dx = Val(Left(t, 1)): dz = Val(Right(t, 1))
                st = ""
                For dat = 0 To 666
              d0 = Format(dat, "000")
       If Sgn(InStr(d0, dx)) + Sgn(InStr(d0, dz)) > 1 Then
          st = st & d0 & " "
         End If
        Next
       Next
      Next
   [C2].Resize(UBound(Arr), 1) = st

End Sub

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr$(), dr, r&, i&, j&
   
    ReDim ar(1 To 999)
    For i = 1 To UBound(ar)
        ar(i) = Format(i, "000")
    Next i
    br = [A2].CurrentRegion
    With CreateObject("Vbscript.RegExp")
        For i = 1 To UBound(br)
            cr = Split(Trim(br(i, 1)))
            For j = 0 To UBound(cr)
                cr(j) = Mid(cr(j), 1, 1) & "\d?" & Mid(cr(j), 2, 1)
            Next j
            .Pattern = Join(cr, "|")
            Erase cr: r = 0
            For j = 1 To UBound(ar)
                If .test(numSort(CStr(ar(j)))) Then
                     r = r + 1
                     ReDim Preserve cr(1 To r)
                     cr(r) = ar(j)
                End If
            Next j
            br(i, 1) = Join(cr)
        Next i
    End With
   
    Columns(3).ClearContents
    [C2].Resize(UBound(br)) = br
    Beep
End Sub
Function numSort(strTxt$) As String
    Dim ar(9) As Byte, i&, n As Byte
    For i = 1 To Len(strTxt)
        n = Val(Mid(strTxt, i, 1))
        ar(n) = ar(n) + 1
    Next
    For i = 0 To 9
        If ar(i) > 0 Then numSort = numSort & String(ar(i), CStr(i))
    Next
End Function

gwjkkkkk

请楼主参考附件

yhy95331

gwjkkkkk 发表于 2023-2-15 20:07
请楼主参考附件

感谢大师，一个字牛

jz_l