2

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.

The file is uploaded here. 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

Please help!

4

1 に答える 1

2

これはあなたがしようとしていることですか？エラー処理は追加していません。データの既存の形式から逸脱することはないと思います。フォーマットが変更された場合は、エラー処理を導入する必要があります。

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

スクリーンショット

ここに画像の説明を入力

于 2013-04-10T06:46:43.903 に答える