识别赋码

usedrange

只是简单判断了一下最后一位是否是数字

ddz79101

usedrange 发表于 2025-4-8 16:11
只是简单判断了一下最后一位是否是数字

谢谢老师！运行成功

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, regEx As Object
   
    Application.ScreenUpdating = False
   
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "\d+"
    ar = Worksheets(1).[A1].CurrentRegion.Value
    With Worksheets(2)
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        br = .Range("A4:F" & r).Value
        For i = 2 To UBound(br)
            For j = 2 To UBound(ar)
                If InStr(ar(j, 1), br(i, 3)) Then
                    If regEx.Text(br(i, 3)) Then
                        br(i, 4) = "666666"
                    Else
                        br(i, 4) = "555555"
                    End If
                End If
            Next j
        Next i
        .[I4].Resize(UBound(br), UBound(br, 2)) = br
        .Activate
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

ddz79101

ykcbf1100 发表于 2025-4-8 16:06
发票号码有没有，没看出来

老师！上线了？谢谢！单元格后面8为数字的就是发票号

翁知江安

Sub test0408()
Dim i, m  As Integer, matches As Object
Dim kk
Dim ar, br, cr As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim reg As Object
Set reg = CreateObject("vbscript.regexp")
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
  d(ar(i, 1)) = ""
Next
br = Sheet2.Range("a1:d" & Sheet2.[a65536].End(xlUp).Row)
cr = Sheet2.Range("d5:d" & Sheet2.[a65536].End(xlUp).Row)
For i = 5 To UBound(br)
   If br(i, 3) <> "" Then
      For Each kk In d.keys
        If InStr(br(i, 3), kk) > 0 Then m = m + 1
      Next
      If m > 0 Then
      With reg
         .Global = 1: .Pattern = "\d{8}"
         Set matches = .Execute(br(i, 3))
      End With
        If matches.Count > 0 Then
            cr(i - 4, 1) = Str(555555)
        Else
            cr(i - 4, 1) = Str(666666)
        End If
       End If
    End If
    m = 0
Next
Sheet2.[d5].Resize(UBound(cr), 1).ClearContents
Sheet2.[d5].Resize(UBound(cr), 1) = cr
End Sub

翁知江安

供参考，欢迎批评指正

ddz79101

gwjkkkkk 发表于 2025-4-8 18:51
Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, regEx As Object

谢谢老师！运行成功！

ddz79101

翁知江安 发表于 2025-4-8 19:54
供参考，欢迎批评指正

谢谢老师！运行成功！