[已解决]关于多个指定字符的查找

mooming

如图 想用VBA实现在A-J列各单元格中查找出现有1到3个 "a" 的单元格值，并将该值复制到 L列
请各位大侠帮帮忙 谢谢
结果就是 只要求含有1-3个指定字符的 单元值 其他的不要
就像如果指定找 字符 a  那就是筛选得到出现1个或者2个或者3个a的值复制到L列
因为a的位置不固定 所以 不知道怎么写 希望各位大侠帮忙 1q.rar (2.07 KB, 下载次数: 16)

2012-2-13 10:54 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-2-13 12:19

1. Sub justtest()
   
2.     Dim R, Arr, K&, i&, j As Byte, Ar(1 To 60000, 1 To 1) As String
   
3.     Arr = Range("A1").CurrentRegion.Value
   
4.     Set R = CreateObject("vbscript.regexp")
   
5.     With R
   
6.         .Global = True
   
7.         .Pattern = "a"
   
8.         For i = 1 To UBound(Arr)
   
9.             For j = 1 To UBound(Arr, 2)
   
10.                 If .test(Arr(i, j)) Then
    
11.                     If .Execute(Arr(i, j)).Count < 4 Then
    
12.                         K = K + 1
    
13.                         Ar(K, 1) = Arr(i, j)
    
14.                     End If
    
15.                 End If
    
16.         Next j, i
    
17.     End With
    
18.     Set R = Nothing
    
19.     Range("l:l").Clear
    
20.     Range("l1").Resize(K, 1) = Ar
    
21. End Sub

复制代码

跳转到最佳答案楼层

wayy

多于３个的要不要？１－３个是挨着的还是不挨着的也行呢？

mooming

多于3个的不要 挨着的或者不挨着的 只要是出现1-3吃得都要

mooming

wayy 发表于 2012-2-13 10:59
多于３个的要不要？１－３个是挨着的还是不挨着的也行呢？

多于3个的不要 挨着或者不挨着的 都要

zjcat35

1. Sub 取()
   
2.   Dim rg As Range
   
3.     For Each rh In Sheet1.Range("a1:j21")
   
4.       If rh Like "*a*" And Not rh Like "*a*a*a*a*" Then
   
5.           Range("l65536").End(3).Offset(1, 0) = rh
   
6.         End If
   
7.       Next rh
   
8.     Range("L1").Delete
   
9. End Sub
   

复制代码

wayy

wayy.rar (10.05 KB, 下载次数: 5)

2012-2-13 11:22 上传

点击文件名下载附件
楼上的简单明了，用他的吧。

mooming

学习验证中先谢谢！

liuguansky

1. Sub justtest()
   
2.     Dim R, Arr, K&, i&, j As Byte, Ar(1 To 60000, 1 To 1) As String
   
3.     Arr = Range("A1").CurrentRegion.Value
   
4.     Set R = CreateObject("vbscript.regexp")
   
5.     With R
   
6.         .Global = True
   
7.         .Pattern = "a"
   
8.         For i = 1 To UBound(Arr)
   
9.             For j = 1 To UBound(Arr, 2)
   
10.                 If .test(Arr(i, j)) Then
    
11.                     If .Execute(Arr(i, j)).Count < 4 Then
    
12.                         K = K + 1
    
13.                         Ar(K, 1) = Arr(i, j)
    
14.                     End If
    
15.                 End If
    
16.         Next j, i
    
17.     End With
    
18.     Set R = Nothing
    
19.     Range("l:l").Clear
    
20.     Range("l1").Resize(K, 1) = Ar
    
21. End Sub

复制代码

hrpotter

根据5楼的，用数组写了个

1. Sub 取数()
   
2.     Dim i, j, k As Integer
   
3.     Dim ar, br(1 To 10000)
   
4.     ar = Range("a1").CurrentRegion
   
5.     For i = 1 To UBound(ar)
   
6.         For j = 1 To UBound(ar, 2)
   
7.             If ar(i, j) Like "*a*" And Not ar(i, j) Like "*a*a*a*a*" Then
   
8.                 k = k + 1
   
9.                 br(k) = ar(i, j)
   
10.             End If
    
11.         Next j, i
    
12.         Range("l:l").ClearContents
    
13.         Range("l1").Resize(k, 1) = Application.Transpose(br)
    
14. End Sub

复制代码

独股求胜

学习了，真是好东西，我也要下来研究。