Excel VBA - 日期格式转换
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/15918073/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA - Date Format Conversion
提问by Tejas
I have come across a challenging task which I am not able to solve using many workarounds.
我遇到了一项具有挑战性的任务，我无法使用许多变通方法来解决。
In one column I have dates, the date can be in following three formats:
在我有日期的一栏中，日期可以是以下三种格式：
1) Simple dd/mm/yy
2) dd/mm/yy but may have words "before,after or about" around it. Any one of it and we just need to delete those words in this case.
3) Date in a numeric format. A long decimal values like 1382923.2323 but actually I can get a date from it after conversion.
1) 简单的 dd/mm/yy
2) dd/mm/yy 但周围可能有“之前、之后或大约”字样。在这种情况下，其中任何一个，我们只需要删除这些词。
3) 数字格式的日期。像 1382923.2323 这样的长十进制值，但实际上我可以在转换后从中获取日期。
The file is uploaded here. Date_format_macro_link
文件上传到这里。Date_format_macro_link
I wrote the following code but it's giving wrong results.
我写了下面的代码，但它给出了错误的结果。
Sub FormatDates_Mine()
ManualSheet.Activate
ManualSheet.Cells.Hyperlinks.Delete
ManualSheet.Cells.Interior.ColorIndex = xlNone
ManualSheet.Cells.Font.Color = RGB(0, 0, 0)
lastRow = ManualSheet.Range("A" & Rows.Count).End(xlUp).Row
Col = "A"
For i = 2 To lastRow
Cells(i, Col) = Trim(Replace(Cells(i, Col), vbLf, "", 1, , vbTextCompare))
If InStr(1, Cells(i, Col), "about", vbTextCompare) <> 0 Then
Cells(i, Col) = Trim(Replace(Cells(i, Col), "about", "", 1, , vbTextCompare))
Cells(i, Col).Interior.Color = RGB(217, 151, 149)
End If
If InStr(1, Cells(i, Col), "after", vbTextCompare) <> 0 Then
Cells(i, Col) = Trim(Replace(Cells(i, Col), "after", "", 1, , vbTextCompare))
Cells(i, Col).Interior.Color = RGB(228, 109, 10)
End If
If InStr(1, Cells(i, Col), "before", vbTextCompare) <> 0 Then
Cells(i, Col) = Trim(Replace(Cells(i, Col), "before", "", 1, , vbTextCompare))
Cells(i, Col).Interior.Color = RGB(228, 109, 10)
End If
DateParts = Split(Cells(i, Col), "/", , vbTextCompare)
Cells(i, Col) = Format(Cells(i, Col), "dd/mm/yyyy")
Next i
Range("D:E").HorizontalAlignment = xlCenter
End Sub
The file is uploaded here. Date_format_macro_link
文件上传到这里。Date_format_macro_link
Please help!
请帮忙！
采纳答案by Siddharth Rout
Is this what you are trying? I have not added any error handling. I am assuming that you will not be deviating for the existing format of your data. If the format changes then you WILL have to introduce error handling.
这是你正在尝试的吗？我没有添加任何错误处理。我假设您不会偏离数据的现有格式。如果格式发生变化，那么您将不得不引入错误处理。
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim rng As Range
Dim MyAr() As String
Set ws = ThisWorkbook.Sheets("Data")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
With rng
'~~> Replace "After " in the entire column
.Replace What:="After ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
DoEvents
'~~> Replace "About " in the entire column
.Replace What:="About ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
.NumberFormat = "dd/mm/yyyy"
End With
For i = 2 To lRow
'~~> Remove the End Spaces
.Range("A" & i).Value = Sid_SpecialAlt160(.Range("A" & i).Value)
'~~> Remove time after the space
If InStr(1, .Range("A" & i).Value, " ") Then _
.Range("A" & i).Formula = Split(.Range("A" & i).Value, " ")(0)
'~~> Convert date like text to date
.Range("A" & i).Formula = DateSerial(Split(.Range("A" & i).Value, "/")(2), _
Split(.Range("A" & i).Value, "/")(1), _
Split(.Range("A" & i).Value, "/")(0))
Next i
End With
End Sub
Public Function Sid_SpecialAlt160(s As String)
Dim counter As Long
If Len(s) > 0 Then
counter = Len(s)
While VBA.Mid(s, counter, 1) = "?"
counter = counter - 1
Wend
Sid_SpecialAlt160 = VBA.Mid(s, 1, counter)
Else
Sid_SpecialAlt160 = s
End If
End Function
Screenshot
截屏
