Option Explicit
Const cModule As String = "Reformat File"
Sub ReformatFile()
Dim dtCutoff As Date
Dim csvPath As String, csvXLSX As String
Dim csvWorkbook As Workbook
Dim csvWorksheet As Worksheet
Dim i As Long, rowData As Long, colData As Long
Dim rData As Range
'get CSV filename, exit if canceled
csvPath = Application.GetOpenFilename("CSV File, *.csv")
If csvPath = "False" Then Exit Sub
'INPUT DATE - uses regional settings for date format
dtCutoff = Application.InputBox("Enter Cut Off Date, blank to Exit", "Cut Off Date", 0, , , , , 2)
If CLng(dtCutoff) = 0 Then Exit Sub
Application.ScreenUpdating = False
'make XLSX file name
i = InStrRev(csvPath, ".")
csvXLSX = Left(csvPath, i) & "xlsx"
'open CSV into new WB
Workbooks.Open Filename:=csvPath
Set csvWorkbook = ActiveWorkbook
Set csvWorksheet = ActiveSheet
Set rData = csvWorksheet.Cells(1, 1).CurrentRegion
With rData
.EntireColumn.AutoFit
'IF A CELL IN COLUMN K IS NOT BLANK, MOVE THE CELLS (OF THAT ROW) HIJK TO GHIJ
For rowData = 1 To .Rows.Count
If Len(.Cells(rowData, 11).Value) > 0 Then
For colData = 7 To 10
.Cells(rowData, colData).Value = .Cells(rowData, colData + 1).Value
Next colData
.Cells(rowData, 11).ClearContents
End If
Next rowData
'DELETE COLUMN A (UPRN)
.Columns(1).Delete
'DELETE COLUMNS NEWLY D & E & F (UNUSED ADDRESS FIELDS)
.Columns(6).Delete
.Columns(5).Delete
.Columns(4).Delete
'CHECK THE LAST 4 CHARACTERS OF ALL CELLS IN COLUMN E AND DELETE THAT RESPECTIVE ROW IF THE LAST FOUR CHARACTERS DO NOT EQUAL "2099"
For rowData = .Rows.Count To 1 Step -1 ' bottom's up
If Right(.Cells(rowData, 5).Value, 4) <> "2099" Then .Rows(rowData).EntireRow.Delete
Next rowData
'ADDED - make text into real dates, region settings independent
For rowData = 1 To .Rows.Count
'DD.MM.YYYY
'01.05.2019
.Cells(rowData, 4).Value = DateSerial(Right(.Cells(rowData, 4).Value, 4), Mid(.Cells(rowData, 4).Value, 4, 2), Left(.Cells(rowData, 4).Value, 2))
.Cells(rowData, 5).Value = DateSerial(Right(.Cells(rowData, 5).Value, 4), Mid(.Cells(rowData, 5).Value, 4, 2), Left(.Cells(rowData, 5).Value, 2))
'DD.MM.YYYY
'04.07.2019 14:18:50
.Cells(rowData, 6).Value = DateSerial(Mid(.Cells(rowData, 6).Value, 7, 4), Mid(.Cells(rowData, 6).Value, 4, 2), Left(.Cells(rowData, 6).Value, 2))
Next rowData
'DELETE ANY ROWS IF THE DATE IN COLUMN F IS LESS THAN OR EQUAL TO THE DATE GIVEN IN STEP 1
For rowData = .Rows.Count To 1 Step -1 ' bottom's up
If .Cells(rowData, 6).Value <= dtCutoff Then .Rows(rowData).EntireRow.Delete
Next rowData
'ADDED - should use regional settings
.Columns(6).NumberFormat = "m/d/yyyy"
.Columns(5).NumberFormat = "m/d/yyyy"
.Columns(4).NumberFormat = "m/d/yyyy"
End With
'delete xlsx if exists
Application.DisplayAlerts = False
On Error Resume Next
Kill csvXLSX
On Error GoTo 0
Application.DisplayAlerts = True
csvWorkbook.SaveAs Filename:=csvXLSX, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
csvWorkbook.Close
ThisWorkbook.Activate
Application.ScreenUpdating = True
Call MsgBox("File saved as " & vbCrLf & vbCrLf & csvXLSX, vbInformation + vbOKOnly, cModule)
End Sub