Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 130|回复: 5

提取数,用VBA

[复制链接]
发表于 2021-11-23 10:16 | 显示全部楼层 |阅读模式
提取对应数,请用VBA实现

提取.rar

6.8 KB, 下载次数: 15

发表于 2021-11-23 10:37 | 显示全部楼层
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
回复

使用道具 举报

发表于 2021-11-23 10:55 | 显示全部楼层
正则法
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



回复

使用道具 举报

发表于 2021-11-23 11:05 | 显示全部楼层
  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
复制代码
回复

使用道具 举报

发表于 2021-11-23 18:05 | 显示全部楼层

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
回复

使用道具 举报

发表于 2021-11-23 19:15 | 显示全部楼层
大量数据的情况下,下面的方法是最快速的,没有之一。
  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
复制代码

评分

参与人数 2学分 +4 收起 理由
cutecpu + 2 学习了
AmoKat + 2 学习了

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2021-11-27 19:39 , Processed in 0.251517 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表