请教老师：在文件名中智能提取日期数字

ak47ok

如题、详见附件，有劳高手！

qy1219no2

年份都是2014年么，且都是“2014”开头么

doitbest

Public Sub abc()
Dim ar, rep, i
ar = Range([a2], [a65536].End(3))
Set rep = CreateObject("vbscript.regexp")
rep.Global = True
rep.Pattern = "[\d-/\s]{6,}"
For i = 1 To UBound(ar)
  ar(i, 1) = Replace(Trim(rep.Execute(ar(i, 1))(0)), " ", "-")
Next
[b2].Resize(UBound(ar)) = ar
End Sub

doitbest

变成标准日期格式有点麻烦
比如 2014124，既可理解为1月24日，又可理解为12月4日

ak47ok

doitbest 发表于 2014-8-27 15:08
Public Sub abc()
Dim ar, rep, i
ar = Range([a2], [a65536].End(3))

还有个问题想麻烦老师：
按老师的代码提取日期提取到B列后，如何将A列的中这些日期数字（包括这些日期格式中的/-_ 等符号）同时删除？

因自己水平有限对代码中的数组不知如何修改。再次麻烦老师指导、谢谢！！！

doitbest

Public Sub abc()
Dim ar, rep, i
ar = Range("a2:c" & [a65536].End(3).Row)
Set rep = CreateObject("vbscript.regexp")
rep.Global = True
rep.Pattern = "[\d-/\s]{6,}"
For i = 1 To UBound(ar)
  ar(i, 2) = Replace(Trim(rep.Execute(ar(i, 1))(0)), " ", "-")
  ar(i, 1) = rep.Replace(ar(i, 1), "")
Next
[a2].Resize(i - 1, 2) = ar
End Sub

liu-aguang

1. Sub test()
   
2.     arr = Sheets(1).UsedRange.Resize(, 2)
   
3.     Set reg = CreateObject("vbscript.regexp")
   
4.     reg.Pattern = "\d{4}([-/ ]*)\d+([-/ ]*)\d+"
   
5.     For i = 2 To UBound(arr)
   
6.         If reg.test(arr(i, 1)) Then
   
7.             Set mh = reg.Execute(arr(i, 1))
   
8.             s = mh(0)
   
9.             If Len(mh(0)) >= 8 Then
   
10.                 k = mh(0).submatches(0)
    
11.                 If Len(k) = 0 Then
    
12.                 arr(i, 2) = s
    
13.                 Else
    
14.                   s = Format$(s, "yyyy" & k & "mm" & k & "dd")
    
15.                   arr(i, 2) = Replace(s, k, "")
    
16.                 End If
    
17.             Else
    
18.                If Len(s) = 6 Then
    
19.                 arr(i, 2) = Left(s, 4) & "0" & Mid(s, 5, 1) & "0" & Right(s, 1)
    
20.                Else
    
21.                 If Mid(s, 5, 2) > 12 Then
    
22.                     arr(i, 2) = Left(s, 4) & "0" & Mid(s, 5, 1) & Right(s, 2)
    
23.                 Else
    
24.                     arr(i, 2) = Left(s, 4) & Mid(s, 5, 2) & "0" & Right(s, 1)
    
25.                 End If
    
26.                End If
    
27.             End If
    
28.         End If
    
29.     Next
    
30.     Sheets(1).Range("a1").Resize(UBound(arr), 2) = arr
    
31. End Sub
    

复制代码

liu-aguang

智能提取日期数字v1.rar (10 KB, 下载次数: 19)

2014-8-27 18:22 上传

点击文件名下载附件

ak47ok

liu-aguang 发表于 2014-8-27 18:21

？？我在2003版运行没有出结果？

liu-aguang

ak47ok 发表于 2014-8-27 18:27
？？我在2003版运行没有出结果？

代码执行可在2003中执行的.下面是执行结果: