[已解决]求个VBA

三田

Book13.rar (8.28 KB, 下载次数: 10)

2013-1-26 23:53 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-27 01:15

1. Option Explicit
   
2. 
   
3. Sub 提取数据()
   
4.     Dim arr, result(), temp As Object, k&, i&, j&
   
5.     Dim iRow&
   
6.     iRow = Cells(Rows.Count, 1).End(xlUp).Row
   
7.     arr = Range("a1:a" & iRow)
   
8.     ReDim result(1 To iRow, 1 To 3)
   
9.     Dim reg As Object
   
10.     Set reg = CreateObject("VBScript.regExp")
    
11.     With reg
    
12.         .Global = True
    
13.         .Pattern = "(\d+)/(\d+)/(\d+)"
    
14.         For i = 1 To UBound(arr)
    
15.             If .test(arr(i, 1)) Then
    
16.                 k = k + 1
    
17.                 Set temp = .Execute(arr(i, 1))
    
18.                 For j = 1 To UBound(result, 2)
    
19.                     result(k, j) = "'" & temp(0).Submatches(j - 1)
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.     End With
    
24.     Range("e1").Resize(k, 3) = result
    
25.     Set reg = Nothing
    
26.     MsgBox "提取完成"
    
27. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Option Explicit
   
2. 
   
3. Sub 提取数据()
   
4.     Dim arr, result(), temp As Object, k&, i&, j&
   
5.     Dim iRow&
   
6.     iRow = Cells(Rows.Count, 1).End(xlUp).Row
   
7.     arr = Range("a1:a" & iRow)
   
8.     ReDim result(1 To iRow, 1 To 3)
   
9.     Dim reg As Object
   
10.     Set reg = CreateObject("VBScript.regExp")
    
11.     With reg
    
12.         .Global = True
    
13.         .Pattern = "(\d+)/(\d+)/(\d+)"
    
14.         For i = 1 To UBound(arr)
    
15.             If .test(arr(i, 1)) Then
    
16.                 k = k + 1
    
17.                 Set temp = .Execute(arr(i, 1))
    
18.                 For j = 1 To UBound(result, 2)
    
19.                     result(k, j) = "'" & temp(0).Submatches(j - 1)
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.     End With
    
24.     Range("e1").Resize(k, 3) = result
    
25.     Set reg = Nothing
    
26.     MsgBox "提取完成"
    
27. End Sub

复制代码

zjdh

正则表达式搜索，学习了！