Text to Date Conversion

[peelamedu_bulls]

I have a column that has an extra "1" at the start. The requirement is to strip that extra character/number and convert the date to a MM/DD/YYYY format.

Column A
1140430
1141124
1140403

Column A
14/04/2030
14/11/2024
14/04/2003

is there a VBA way to do this, preferably without creating any new column and do this manipulation in the same Column A

 

[alansidman]

Option Explicit


Sub foo()
    Dim lr As Long, i As Long
    lr = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To lr
        Range("A" & i) = Right(Range("A" & i), 6)
        Range("A" & i) = Left(Range("A" & i), 2) & "/" & Mid(Range("A" & i), 3, 2) & "/" & Right(Range("A" & i), 2)
    Next i
End Sub

 

[Kenneth Hobson]

Sub Main()
    Dim r As Range, a, i As Long
    
    Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
    a = WorksheetFunction.Transpose(r)
    
    On Error Resume Next
    For i = 0 To UBound(a)
        a(i) = Right(a(i), 6)
        Debug.Print i, a(i)
        '1140430, 14/04/2030
        a(i) = DateSerial(Right(a(i), 2), Mid(a(i), 3, 2), Left(a(i), 2))
    Next i
    
    r = WorksheetFunction.Transpose(a)
    r.NumberFormat = "dd/mm/yyyy"
End Sub

 

[Akuini]

Just another way:

[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] a1109270a()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1109270-text-date-conversion.html[/COLOR][/I]
[COLOR=Royalblue]Dim[/COLOR] c [COLOR=Royalblue]As[/COLOR] Range, x [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]String[/COLOR]
Application.ScreenUpdating = [COLOR=Royalblue]False[/COLOR]
    [COLOR=Royalblue]For[/COLOR] [COLOR=Royalblue]Each[/COLOR] c [COLOR=Royalblue]In[/COLOR] Range([COLOR=brown]"A1"[/COLOR], Cells(Rows.count, [COLOR=brown]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))
       
        [COLOR=Royalblue]If[/COLOR] IsNumeric(c) [COLOR=Royalblue]And[/COLOR] Len(c) = [COLOR=crimson]7[/COLOR] [COLOR=Royalblue]Then[/COLOR]
            x = Right(c, [COLOR=crimson]6[/COLOR])
            c = DateSerial(Right(x, [COLOR=crimson]2[/COLOR]), [COLOR=Royalblue]Mid[/COLOR](x, [COLOR=crimson]3[/COLOR], [COLOR=crimson]2[/COLOR]), Left(x, [COLOR=crimson]2[/COLOR]))
        [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
   
    [COLOR=Royalblue]Next[/COLOR]
Range([COLOR=brown]"A1"[/COLOR], Cells(Rows.count, [COLOR=brown]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp)).NumberFormat = [COLOR=brown]"MM/DD/YYYY"[/COLOR]
Application.ScreenUpdating = [COLOR=Royalblue]True[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]

 

[Tetra201]

A shorter, faster sub that correctly converts 1140430 into 14/04/2030:

Sub Txt2Date()
    Dim Rng As Range
    Set Rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Rng = Evaluate("INDEX(REPLACE(RIGHT(" & Rng.Address & ",6),5,0,20),0)")
    Rng.TextToColumns , xlDelimited, , , , , , , , , Array(1, 4)
    Rng.NumberFormat = "dd/mm/yyyy"
End Sub

 

[Rick Rothstein]

A shorter, faster sub that correctly converts 1140430 into 14/04/2030:

Sub Txt2Date()
    Dim Rng As Range
    Set Rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Rng = Evaluate("INDEX(REPLACE(RIGHT(" & Rng.Address & ",6),5,0,20),0)")
    Rng.TextToColumns , xlDelimited, , , , , , , , , Array(1, 4)
    Rng.NumberFormat = "dd/mm/yyyy"
End Sub

Here is another way to write a non-looping macro for the OP. I am not sure, but I think VBA/Excel will end up doing less work overall using this code.

Sub Txt2Date()
  Dim Addr As String
  Addr = "A1:A" & Cells(Rows.Count, "A").End(xlUp).Row
  Range(Addr) = Evaluate(Replace("IF({1},TEXT(RIGHT(REPLACE(RIGHT(@,6),5,0,MID(@,2,2)&20),8),""00\/00\/0000""))", "@", Addr))
  Range(Addr).NumberFormat = "dd/mm/yyyy"
End Sub

 

[Tetra201]

... I am not sure, but I think VBA/Excel will end up doing less work overall using this code...

With a 100,000-row dataset in Excel 2010
Sub from Post # 5: ~0.95 sec
Sub from Post # 6: ~1.35 sec

 

[Kenneth Hobson]

This is a mute point since the op has not responded. If the dates are always expected to be year 2000+, posts #5 and #6 are fine. Two digit year dates can be a problem for some routines.

 

[Kenneth Hobson]

For giggles, I did a few times tests. The suffix number is the code in that post number.

Txt2Date3 0.501302083
Txt2Date5 1.44140625
Txt2Date6 2.063802083

Sub Avg3RunTimes()
    Dim d As Double, dd As Double
    Dim s As String
    Dim j As Integer, k As Integer
    Dim jj As Integer, kk As Integer
    
    jj = 3    'Number of single runs.
    kk = 3  'Number of replicate runs
    
    For k = 1 To kk 'Replicate runs
        For j = 1 To jj 'Single runs
            s = "Txt2Date" & Choose(j, 3, 5, 6)
            Fill100kRows
            d = Timer
            Application.Run s
            dd = Timer
            Debug.Print s, dd - d & " seconds."
        Next j
    Next k
End Sub

Sub Fill100kRows()
    Range("A2:A100001").Clear
    Range("A2") = ""
    Range("A3") = 1140499
    Range("A4:A100001") = 1140403
End Sub

 

[Tetra201]

Here is an even faster sub:

Sub Txt2Date_v2()
    Dim Rng As Range
    Set Rng = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Rng = Evaluate("INDEX(REPLACE(" & Rng.Address & ",6,0,20),0)")
    Rng.TextToColumns , xlFixedWidth, , , , , , , , , Array(Array(0, 9), Array(1, 4))
    Rng.NumberFormat = "dd/mm/yyyy"
End Sub

It takes it ~0.85 sec to process a 100,000-row dataset in Excel 2010.
Kenneth's sub from Post # 3 was consistently at ~1.1 sec.
Rick's sub from Post # 6 was consistently at ~1.35 sec.

Just in case, here is my sub for creating a 100,000-row dataset:

Sub Fill_100K_Rows()
    Dim i As Long
    Application.ScreenUpdating = False
    For i = 1 To 100000
        Range("A" & i) = 1 & _
            Format(Application.RandBetween(1, 28), "00") & _
            Format(Application.RandBetween(1, 12), "00") & _
            Format(Application.RandBetween(0, 99), "00")
    Next i
    Application.ScreenUpdating = True
End Sub