Converting Column To Specific Date Format

[HTSCF Fareha]

I'm hoping that somebody can please help me to fathom this one out.

I have a column of data that has been captured from a bespoke database programme which on the face of it, looks to be in dd/mm/yyyy time format. Having tried to manually select the column and then convert it to the required dd/mm/yyyy format (basically removing the time element), I soon realised that something was not quite right as after applying the required date format, it seemed on the face of it to do absolutely nothing.

Having then Googled the issue, I believe that the column has been exported and saved in text format and hence why it would not convert to the required date format.

Ultimately I am trying to get this to function as a macro which will be part of a larger project. Using the macro recorder, I arrived at the following code which although a bit rough and ready, was hoping would provide me with a column 'D' in the required dd/mm/yyyy format, but it only appears to be working on some of the cells and not others.


Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Selection.NumberFormat = "dd/mm/yyyy"

I'd really appreciate help in getting a bit of macro code to achieve my goal.

Thanks!

[June7]

Why is there no code in this workbook?

Since I am in the U.S., can be difficult for me to test code with international date.

Problem appears to be d/m/y structure of string dates. Conversion fails on those dates where day is greater than 12. Likely because VBA expects U.S. date structure of m/d/y.

Possibly will have to parse date string to discrete date parts, recombine as U.S. structure, convert with DateValue(), save to cells and set formatting. Try setting Date format with U.K. location instead of Custom format.

Expression in cell:
=DATEVALUE(MID(D2,4,2) & "/" & LEFT(D2,2) & "/" & MID(D2,7,4))
With Date format using U.K. location, d/m/yyyy structure is available option and dates display correctly for me.

[snb]

Please read how you can define fields in the 'Texttocolumns' method.
Even the textcolumns wizard shows the options.

[p45cal]

Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 9)), TrailingMinusNumbers:=True
It loses the time element.

To include time:
With Range(Range("D2"), Cells(Rows.Count, "D").End(xlUp))
.TextToColumns Destination:=Range("D2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1)), TrailingMinusNumbers:=True
.NumberFormat = "mm/dd/yyyy hh:mm"
For Each cll In .Cells
cll.Value = cll.Value + cll.Offset(, 1).Value
Next cll
.Offset(, 1).Clear
End With

[arnelgp]

another option, run subFmtDDMMYYYY sub.

[June7]

Nice, p45cal. Works.

However, don't need to actually Select anything.

Good practice to qualify references.


With Worksheets("Involved")
.Columns("D:D").TextToColumns Destination:=.Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 9)), TrailingMinusNumbers:=True
.Columns("D:D").NumberFormat = "dd/mm/yyyy"
End With

[HTSCF Fareha]

My thanks to all who contributed to helping me on this one.

Each of the options provided by p45cal (post #4), arnelgp (post #5) and June7 (post #6) work!

[snb]

@ June

I agree, but advise to be consistent:


With sheets("Involved").Columns(4)
.TextToColumns .cells(1), ,, , ,, , , ,array(Array(1, 4), Array(2, 9))
.NumberFormat = "dd/mm/yyyy"
End With

Alternative:


Sub M_snb()
columns(4).replace "/", "-"
End sub

[HTSCF Fareha]

another option, run subFmtDDMMYYYY sub.

Just noticed that this swaps the day and month about. :(

[arnelgp]

change the sub to this:


Public Sub subFmtDDMMYYYY()
Dim rw As Long, last_rw As Long
Dim vlue As Variant
last_rw = Cells(Cells.Rows.Count, 4).End(xlUp).Row
For rw = 2 To last_rw
vlue = Cells(rw, 4)
Cells(rw, 4) = CDate(Month(vlue) & "/" & Day(vlue) & "/" & Year(vlue)) + TimeValue(vlue)
Cells(rw, 4).NumberFormat = "dd/mm/yyyy"
Next
End Sub

[HTSCF Fareha]

Sorry arnelgp, it is still not working. It seems to swap dd and mm for anything under the value of 12.

[arnelgp]

it seems that most of the cells are "not valid" date (examle using =Month("D4") will result in #VALUE! result.
i change the sub to handle invalidate dates.


Public Sub subFmtDDMMYYYY()
Dim rw As Long, last_rw As Long
Dim vlue As Variant
Dim txt As String
Dim dte As Variant, tim As String
last_rw = Cells(Cells.Rows.Count, 4).End(xlUp).Row
For rw = 2 To last_rw
vlue = Cells(rw, 4)
txt = WorksheetFunction.Text(Cells(2, 4), "m")
If IsNumeric(txt) Then
'if numeric, it is a valid date
Cells(rw, 4) = CDate(Month(vlue) & "/" & Day(vlue) & "/" & Year(vlue)) + TimeValue(vlue)
Else
'not valid date
dte = Split(vlue, "/")
tim = Split(dte(2))(1)
dte(2) = Replace$(dte(2), tim, "")
Cells(rw, 4) = CDate(dte(1) & "/" & dte(0) & "/" & dte(2)) + TimeValue(tim)
End If
Cells(rw, 4).NumberFormat = "dd/mm/yyyy"
Next
End Sub

[georgiboy]

Here is another option using an array and the function 'CDate', it will keep the time and date.

Sub test()
Dim rng As Range, var As Variant, x As Long

With Worksheets("Involved")
Set rng = .Range(.Cells(2, "D"), .Cells(Rows.Count, "D").End(xlUp))
End With

var = rng.Value

For x = 1 To UBound(var)
var(x, 1) = CDate(var(x, 1))
Next x

rng = var
End Sub

[HTSCF Fareha]

Wow, I hadn't realised that some of the dates were not even proper ones! I'm not sure how / why the programme that produces the original output would generate anything like this as it seems illogical.

Anyhow, my thanks arnelgp as this now formats the dates as required and removes the time element as this is not required. However, I have only more thing to ask if I may. Can this code be modified so that it will work on multiple worksheets contained within a single workbook?

At the moment it appears to work on the currently selected worksheet if this is the last one, but ignores any worksheets before it leaving the data untouched. If say the first worksheet is selected, then the sub run, it works on that worksheet okay, but throws a runtime error 13 type mismatch on
Cells(rw, 4) = CDate(Month(vlue) & "/" & Day(vlue) & "/" & Year(vlue)) + TimeValue(vlue) on the next.

Here is my sub along with your code incorporated within it that I hope can be modified to work as required.


Private Sub RMS_History(ws)

Dim x As Variant
Dim rw As Long, last_rw As Long
Dim vlue As Variant
Dim txt As String
Dim dte As Variant, tim As String

Application.ScreenUpdating = False

' -------------------------------------------------------
' Set font for each worksheet

With ws
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = 11
.Cells.VerticalAlignment = xlVAlignCenter
.Cells.HorizontalAlignment = xlHAlignLeft

' -------------------------------------------------------
' Perform the basic editing

' Tidy date column by converting from text to required date format

last_rw = Cells(Cells.Rows.Count, 4).End(xlUp).Row
For rw = 2 To last_rw
vlue = Cells(rw, 4)
txt = WorksheetFunction.Text(Cells(2, 4), "m")
If IsNumeric(txt) Then
'if numeric, it is a valid date
Cells(rw, 4) = CDate(Month(vlue) & "/" & Day(vlue) & "/" & Year(vlue)) + TimeValue(vlue)
Else
'not valid date
dte = Split(vlue, "/")
tim = Split(dte(2))(1)
dte(2) = Replace$(dte(2), tim, "")
Cells(rw, 4) = CDate(dte(1) & "/" & dte(0) & "/" & dte(2)) + TimeValue(tim)
End If
Cells(rw, 4).NumberFormat = "dd/mm/yyyy"
Next


.Columns("E:E").Delete ' Delete column E as this is not required

' Delete all rows with a date older than eighteen months

.AutoFilterMode = False
Dim FilterRange As Range, myDate As Date
myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))
Set FilterRange = .Range("D2:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
On Error Resume Next
With FilterRange
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
End With
Err.Clear
Set FilterRange = Nothing
.AutoFilterMode = False

End With

Application.ScreenUpdating = True

End Sub

[georgiboy]

Didn't realise you wanted to drop the time part, just in case you are interested, below is the updated version of the code above but for date only. It works fine for me using UK date regional settings.

Sub test()
Dim rng As Range, var As Variant, x As Long

With Worksheets("Involved")
Set rng = .Range(.Cells(2, "D"), .Cells(Rows.Count, "D").End(xlUp))
End With

var = rng.Value

For x = 1 To UBound(var)
var(x, 1) = Int(CDate(var(x, 1)))
Next x

rng = var
End Sub

[HTSCF Fareha]

Many thanks georgiboy, the code you have provided in the previous post does indeed work and, by removing the 'with' elements will work on multiple worksheets in the same workbook.

I am still trying to understand VBA and looking to learn as I go. I think I appreciate how your code is working, but not how the rng = var final line?

[arnelgp]

you can use Array() of worksheet names and Array() of columns to process multiple sheets:


Private Sub RMS_UpdateDateColumn()

Dim arrWsh As Variant
Dim arrCol As Variant
Dim i As Integer

' the worksheets to work with, Change the name if necessary
arrWsh = Array("Involved", "Sheet2")

' the column number where the date is located, change the column Number if necessary
arrCol = Array(4, 4)

For i = 0 To UBound(arrWsh)
Call RMS_History(Worksheets(arrWsh(i)), arrCol(i))
Next

End Sub

Private Sub RMS_History(ByRef ws As Worksheet, ByVal nCol As Long)

Dim x As Variant
Dim rw As Long, last_rw As Long
Dim vlue As Variant
Dim txt As String
Dim dte As Variant, tim As String

Application.ScreenUpdating = False

' -------------------------------------------------------
' Set font for each worksheet

With ws
.Cells.Font.Name = "Calibri"
.Cells.Font.Size = 11
.Cells.VerticalAlignment = xlVAlignCenter
.Cells.HorizontalAlignment = xlHAlignLeft

' -------------------------------------------------------
' Perform the basic editing

' Tidy date column by converting from text to required date format

last_rw = .Cells(.Cells.Rows.Count, nCol).End(xlUp).Row
For rw = 2 To last_rw
vlue = .Cells(rw, nCol)
txt = WorksheetFunction.Text(.Cells(rw, nCol), "m")
If IsNumeric(txt) Then
'if numeric, it is a valid date
.Cells(rw, nCol) = CDate(Month(vlue) & "/" & Day(vlue) & "/" & Year(vlue)) + TimeValue(vlue)
Else
'not valid date
dte = Split(vlue, "/")
tim = Split(dte(2))(1)
dte(2) = Replace$(dte(2), tim, "")
.Cells(rw, nCol) = CDate(dte(1) & "/" & dte(0) & "/" & dte(2)) + TimeValue(tim)
End If
.Cells(rw, nCol).NumberFormat = "dd/mm/yyyy"
Next


.Columns("E:E").Delete ' Delete column E as this is not required

' Delete all rows with a date older than eighteen months

.AutoFilterMode = False
Dim FilterRange As Range, myDate As Date, myCol As String

myCol = ColumnLetter(nCol)
myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))

Set FilterRange = .Range(myCol & "2:" & myCol & .Cells(.Rows.Count, 1).End(xlUp).Row)
FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
On Error Resume Next
With FilterRange
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
End With
Err.Clear
Set FilterRange = Nothing
.AutoFilterMode = False

End With

Application.ScreenUpdating = True

End Sub

' chatgpt
Function ColumnLetter(ByVal ColNum As Integer) As String
Dim vArr As Variant
vArr = Split(Cells(1, ColNum).Address(True, False), "$")
ColumnLetter = vArr(0)
End Function

[georgiboy]

I think I appreciate how your code is working, but not how the rng = var final line?

Just to explain:

The below part sets the range to work on:

With Worksheets("Involved")
Set rng = .Range(.Cells(2, "D"), .Cells(Rows.Count, "D").End(xlUp))
End With


This part writes the values in that range to an array named 'var':

var = rng.Value

This part loops through that array and converts the text to a UK date format (within the array only):

For x = 1 To UBound(var)
var(x, 1) = Int(CDate(var(x, 1)))
Next x


As the conversion was made only within the array (in memory) the values need to be written back to the worksheet, the below line does this:

rng = var

To work with a range of spreadsheets, you can use:

Sub test1()
Dim rng As Range, var As Variant, x As Long, ws As Worksheet

For Each ws In Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
With ws
Set rng = .Range(.Cells(2, "D"), .Cells(Rows.Count, "D").End(xlUp))
End With

var = rng.Value

For x = 1 To UBound(var)
var(x, 1) = Int(CDate(var(x, 1)))
Next x

rng = var
Next ws
End Sub


To work with all worksheets in a workbook, you can use:

Sub test2()
Dim rng As Range, var As Variant, x As Long, ws As Worksheet

For Each ws In Sheets
With ws
Set rng = .Range(.Cells(2, "D"), .Cells(Rows.Count, "D").End(xlUp))
End With

var = rng.Value

For x = 1 To UBound(var)
var(x, 1) = Int(CDate(var(x, 1)))
Next x

rng = var
Next ws
End Sub

[HTSCF Fareha]

My thanks to arnelgp for their solution and for georgiboy for theirs along with the explanation of coding. This is very helpful. :thumb

Two different approaches to the same problem, that both provide the solution.