Excel VBA - 日期格式转换

Question

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

在一列中我有日期，日期可以是以下三种格式：

1) 简单的 dd/mm/yy

2) dd/mm/yy 但周围可能有“之前、之后或大约”字样。任何 其中之一，我们只需要在这种情况下删除这些单词。

3) 数字格式的日期。长十进制值，如 1382923.2323 但实际上我可以在转换后从中得到一个日期。

文件已上传至此处。 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

截图