提取数,用VBA

为工作

提取对应数，请用VBA实现

林木水

like法
Sub LIKE法()
    Dim ARR, X, BRR(), K
    ARR = Range("g3:g" & Cells(Rows.Count, "G").End(xlUp).Row)
    For X = 1 To UBound(ARR, 1)
        If ARR(X, 1) Like "??????????????2*" Then
            K = K + 1
            ReDim Preserve BRR(1 To K)
            BRR(K) = ARR(X, 1)
        End If
    Next X
    Range("i3").Resize(UBound(BRR)) = Application.Transpose(BRR)
End Sub

林木水

正则法
Sub 正则法()
Dim RG As Object
Set RG = CreateObject("VBSCRIPT.REGEXP")
Dim K, BRR(), X, ARR
ARR = Range("g3:g" & Cells(Rows.Count, "G").End(xlUp).Row)
For X = 1 To UBound(ARR, 1)
With RG
    .Global = True
    .Pattern = "(.{14})(2).{5}"
    If .Test(ARR(X, 1)) = True Then
        K = K + 1
        ReDim Preserve BRR(1 To K)
        BRR(K) = ARR(X, 1)
    End If
End With
Next XRange("i3").Resize(UBound(BRR)) = Application.Transpose(BRR)End Sub

风林火山

1. Sub tiqu()
   
2. Dim ARR, BRR(), K As Byte, N As Byte
   
3.     ARR = Range("g2").CurrentRegion
   
4.     For K = 2 To UBound(ARR)
   
5.         If VBA.Mid(ARR(K, 1), 15, 1) = 2 Then
   
6.             N = N + 1
   
7.             ReDim Preserve BRR(1 To N)
   
8.             BRR(N) = ARR(K, 1)
   
9.         End If
   
10.     Next K
    
11.     Range("i2") = "现号"
    
12.     Range("i3").Resize(N) = Application.Transpose(BRR)
    
13. End Sub
    

复制代码

AmoKat

Sub Test()
    N = 2
    For Each R In Range("G2").CurrentRegion
        If Mid(R, 15, 1) = "2" Then
            N = N + 1: Cells(N, "I") = R.Value
        End If
    Next
End Sub

大灰狼1976

大量数据的情况下，下面的方法是最快速的，没有之一。

1. Sub 生成大量虚拟数据()
   
2. [g3].Resize(100000) = ["11925WL62600M0"&row(1:100000)&"02715"]
   
3. End Sub

复制代码

1. Sub test()
   
2. With [g2].CurrentRegion
   
3.   .AutoFilter 1, "??????????????2*"
   
4.   .Offset(1).Copy [i3]
   
5.   .AutoFilter
   
6. End With
   
7. End Sub

复制代码