Excel VBA - Преобразование формата даты

Question

Я столкнулся с трудной задачей, которую я не могу решить, используя множество обходных решений.

В одном столбце у меня даты, дата может быть в следующих трех форматов:

1) Простой дд/мм/гг

2) дд/мм/гг, но могут иметь слова " до, после или вокруг «вокруг». Любой один из них, и нам просто нужно удалить эти слова в этом случае.

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 

Скриншот