vba统一日期格式

lpzxhjp

高手能写一段代码，一次性将附件中杂乱无章的日期统一成标准的日期格式吗？谢谢！！！

yjh_27

自定义函数

zbkfbyb

Function 修改(zf)


    zf = Replace(zf, "，", "/")
    zf = Replace(zf, ",", "/")
    zf = Replace(zf, "年", "/")
    zf = Replace(zf, "月", "/")
    zf = Replace(zf, "日", "/")
    zf = Replace(zf, "，", "/")
    zf = Replace(zf, ".", "/")
    zf = Replace(zf, "。", "/")
    zf = Replace(zf, "、", "/")
    If zf = Replace(zf, "/", "") Then zf = Mid(zf, 1, 4) & "/" & Mid(zf, 5, 2) & "/" & Mid(zf, 7, 2)
    zf = CDate(zf)

修改 = zf
End Function
这个样怎么不行呢

zbkfbyb

Function zifu2date(zf)


    zf = Replace(zf, "，", "/")
    zf = Replace(zf, ",", "/")
    zf = Replace(zf, "年", "/")
    zf = Replace(zf, "月", "/")
    zf = Replace(zf, "日", "/")
    zf = Replace(zf, "，", "/")
    zf = Replace(zf, ".", "/")
    zf = Replace(zf, "。", "/")
    zf = Replace(zf, "、", "/")
    If zf = Replace(zf, "/", "") Then zf = Mid(zf, 1, 4) & "/" & Mid(zf, 5, 2) & "/" & Mid(zf, 7, 2)
    zf = CDate(zf)

zifu2date = zf
End Function
我就是把 zifu2date改成了修改啊

yjh_27

我这可以啊

zhaogang1960

邀请收到，请测试：

1. Sub Macro1()
   
2.     Dim arr, i&, s$
   
3.     arr = Range("A5:A" & Range("A65536").End(xlUp).Row)
   
4.     With CreateObject("VBScript.RegExp")
   
5.         .Pattern = "\D"
   
6.         .Global = True
   
7.         .IgnoreCase = False
   
8.         For i = 1 To UBound(arr)
   
9.             s = .Replace(arr(i, 1), "-")
   
10.             If IsNumeric(s) Then
    
11.                 arr(i, 1) = Application.Text(s, "0000-00-00")
    
12.             Else
    
13.                 arr(i, 1) = CDate(s)
    
14.             End If
    
15.         Next
    
16.     End With
    
17.     With [b5].Resize(i - 1)
    
18.         .Value = arr
    
19.         .NumberFormatLocal = "yyyy-mm-dd"
    
20.     End With
    
21. End Sub

复制代码

zhaogang1960

请看附件
信息表.rar (14.71 KB, 下载次数: 169)

2013-11-3 19:15 上传

点击文件名下载附件

jbjbzjb

附件表格整得是乱七八糟!!

1. 
   
2. Sub kkk()
   
3.     Dim theValue As Variant, arr As Variant, i&, theRecordsCount&, theStr$, theFinalRow&
   
4.     Dim reg As Object, theMatch As Variant
   
5.     Set reg = CreateObject("VBScript.RegExp")
   
6.     With reg
   
7.         .Global = True
   
8.         .ignorecase = True
   
9.         .Pattern = "\d+(?=[^\d])?"
   
10.     End With
    
11.     With Sheet1
    
12.         theFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.         If theFinalRow < 5 Then GoTo The_Exit
    
14.         .Range(.Cells(theFinalRow + 1, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
    
15.         .Range(.Cells(5, 3), .Cells(.Rows.Count, 3)).ClearContents
    
16.         arr = .Range(.Cells(5, 1), .Cells(theFinalRow, 1))
    
17.     End With
    
18.     On Error Resume Next
    
19.     For i = 1 To UBound(arr)
    
20.         theStr = ""
    
21.         theValue = arr(i, 1)
    
22.         If Not IsDate(theValue) Then
    
23.             If reg.test(theValue) Then
    
24.                 For Each theMatch In reg.Execute(theValue)
    
25.                     If theStr <> "" Then
    
26.                         theStr = theStr & "," & theMatch
    
27.                     Else
    
28.                         theStr = theMatch
    
29.                     End If
    
30.                 Next theMatch
    
31.                 If InStr(1, theStr, ",") > 0 Then
    
32.                     arr(i, 1) = CDate(theStr)
    
33.                 Else
    
34.                     arr(i, 1) = CDate(Format(theStr, "0000-00-00"))
    
35.                 End If
    
36.             End If
    
37.         Else
    
38.             arr(i, 1) = CDate(arr(i, 1))
    
39.         End If
    
40.     Next i
    
41.     On Error GoTo 0
    
42.     Sheet1.Cells(5, 3).Resize(UBound(arr)) = arr
    
43. The_Exit:
    
44.     Set reg = Nothing
    
45. End Sub
    
46. 
    

复制代码

lpzxhjp

yjh_27 发表于 2013-11-3 18:51
自定义函数

谢谢，很感谢！

lpzxhjp

zhaogang1960 发表于 2013-11-3 19:17
请看附件

非常感谢赵老师。