date - Excel VBA - 日期格式转换

Question

我遇到了一项具有挑战性的任务，我无法使用许多解决方法来解决。

在一栏中我有日期，日期可以采用以下三种格式:

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.

文件上传到这里。 Date_format_macro_link

我编写了以下代码，但它给出了错误的结果。

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

文件上传到这里。 Date_format_macro_link

请帮忙!

Answer 1

这是你正在尝试的吗？我没有添加任何错误处理。我假设您不会偏离数据的现有格式。如果格式发生变化，那么您将不得不引入错误处理。

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

截图