vba code for custom date & time format

Ria · Oct 3, 2014

Hi:

I have text file, I open it in excel 2003. Column A has date (format: 20/06/2014 11:00:00 AM). I wan to change this date & time format to: mm/dd/yyyy hh:mm:ss. I save it in as text file and import data into other program which only reads date format (mm/dd/yyyy hh:mm:ss). Surfing internet with solution but can not make it working.
Here is what I got so far:
1. Range("A2").Value = Format(Range("A2").Value, "mm/dd/yyyy hh:mm:ss")
this gives me only: 6/20/2014 11:00 and missing ss part(seconds). plus it only work for a cell not for range (if I change it to Range ("A:A") then give me error.
2. then I have following code:
im rngCell As Range
Range("A:A").Select

For Each rngCell In Selection
If IsDate(rngCell.Value) Then
rngCell.Value = Format(rngCell.Value, "mm/dd/yyyy") & Format(rngCell.Value, "hh:mm:ss")
End If
Next rngCell
It works fine but does not put space between date and time. If I try rngCell.Value = Format(rngCell.Value, "mm/dd/yyyy") & " " & Format(rngCell.Value, "hh:mm:ss"), it works but skips last :00 part (seconds) from time part.

Any solution will be appreciate.

Thanks,

Ria

Nebu · Oct 3, 2014

Use this code
Dim rngCell As Range
Range("A:A").Select

For Each rngCell In Selection
If IsDate(rngCell.Value) Then
rngCell.Value2 = Format(rngCell.Value, "MM/dd/yyyy h:mm:ss")

End If
Next rngCell

Nebu · Oct 3, 2014

a small Modification
Dim rngCell As Range

Range("A:A").Select
For Each rngCell In Selection
If IsDate(rngCell.Value) Then
rngCell.Value2 = Format(rngCell, "MM/dd/yyyy hh:mm:ss ..")

End If

Next rngCell
Columns("A:A").Select
Selection.Replace What:="..", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Somendra Misra · Oct 3, 2014

Hi Ria,

The problem can be solved with Custom Number format, is there a specific reason to use VBA as you just need to change the format. Try below steps:

1. Select the entire Date column, say A.
2. Press Ctrl+1 or Go to format cell dialogue box and select Number. Than Select Custom and in the Type: Box put this mm/dd/yyyy hh:mm AM/PM.

Press OK. This will apply the desire format.

See the image below.

Regards,

Ria · Oct 3, 2014

Nebu said:
a small Modification
Dim rngCell As Range

Range("A:A").Select
For Each rngCell In Selection
If IsDate(rngCell.Value) Then
rngCell.Value2 = Format(rngCell, "MM/dd/yyyy hh:mm:ss ..")

End If

Next rngCell
Columns("A:A").Select
Selection.Replace What:="..", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

=============================

Hi Nebu:

Thanks for taking time. However, problem is still there. It works only if I use :ss.." but in result it has .. (two periods at the end). if I do not put periods and give space then it does not work.

Any other solution, please.
======================
Here is another problem along with above problem:
I have few text files in folder (for example 5 files). Loop in following code only process one less file ( will process only 4 files) and skip first one. at the end it gives error message. You may solve this, if can do so.

Sub ProcessFile_Macro()
'
' Macro1 Macro
' Macro recorded 30/09/2014 by RK
'

Dim FolderPath As String, path As String, count As Integer, I As Integer, FileName As String

FolderPath = "C:\Users\RK\Desktop\MyDeskTop\NewPC\JM_Hurst\DATA\New"

path = FolderPath & "\*.txt"

FileName = Dir(path)

Do While FileName <> ""
FileName = Dir()
Workbooks.OpenText FileName:= _
FileName, Origin:= _
xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True _
, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
'=======================
Dim rngCell As Range
Range("A:A").Select
For Each rngCell In Selection
If IsDate(rngCell.Value) Then
rngCell.Value2 = Format(rngCell, "MM/dd/yyyy hh:mm:ss ..")
End If
Next rngCell
Columns("A:A").Select
Selection.Replace What:="..", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'==========================
ActiveWorkbook.Save
ActiveWorkbook.Save
ActiveWindow.Close

Loop
End Sub

Ria · Oct 3, 2014

Somendra Misra said:
Hi Ria,

The problem can be solved with Custom Number format, is there a specific reason to use VBA as you just need to change the format. Try below steps:

1. Select the entire Date column, say A.
2. Press Ctrl+1 or Go to format cell dialogue box and select Number. Than Select Custom and in the Type: Box put this mm/dd/yyyy hh:mm AM/PM.

Press OK. This will apply the desire format.

See the image below.
View attachment 11412

Regards,

Hi Misra:

Solution you mentioned is manual. I am looking to automate it because too many files to process in one time. And third party software only read data from my text file after date has been formatted properly.

Regards

Ria

Nebu · Oct 3, 2014

Hi Ria,

I guess I had put a code to take out the two periods at the end in my second posting that code is actually giveing me the format you wanted at my end.

Thanks
Nebu

NARAYANK991 · Oct 3, 2014

Hi Ria ,

With reference to your second problem whose code you have posted , the problem is that the following statement :

FileName = Dir()

is at the beginning of the loop , instead of at the end. This statement retrieves the next file which matches the criterion set in the first Dir statement , which in your case was :

FileName = Dir(path)

Move the statement :

FileName = Dir()

to the end of your loop , as follows :

'==========================
ActiveWorkbook.Save
ActiveWorkbook.Save
ActiveWindow.Close
FileName = Dir()
Loop

Narayan

shrivallabha · Oct 3, 2014

You could post a sample text file (before / after) so that we can see it. Reading codes can be misleading sometimes.

What Somendra has suggested above can be implemented through VBA as well. Just turn the macro recorder on and do the steps, you will get code like below:

Code:

Selection.NumberFormat = "mm/dd/yyyy hh:mm:ss"

Something which you can adopt as below:

Code:

rngCell.NumberFormat = "mm/dd/yyyy hh:mm:ss"

Ria · Oct 3, 2014

shrivallabha said:
You could post a sample text file (before / after) so that we can see it. Reading codes can be misleading sometimes.

What Somendra has suggested above can be implemented through VBA as well. Just turn the macro recorder on and do the steps, you will get code like below:

Code:

Selection.NumberFormat = "mm/dd/yyyy hh:mm:ss"

Something which you can adopt as below:

Code:

rngCell.NumberFormat = "mm/dd/yyyy hh:mm:ss"

Hi Shiva:

I was using what somendra suggested but was not getting right results. then tried to ask for help.
Attached is excel file and txt file to read.
3 problem areas, please look at all 3 if you can:
1. Loop problem, counting one less when process (process one file less).
2. date formatting issue
3. after date formatting, want to close sheet and file. It gives message, "want to save changes=>>YES, then asks tab deliminited message ==>YES, how to turn on both messages to YESS in code.

Thanks for all taking time and helping.

Ria

Somendra Misra · Oct 3, 2014

Hi Ria,

Just a wild shot, try below code, change the path:

Code:

Option Explicit
Sub test()

Dim FolderPath As String, patho As String, count As Integer, I As Integer, FileName As String, paths As String


FolderPath = "C:\Users\A075970\Desktop\"

patho = "*.txt"
paths = "*.csv"
FileName = Dir(FolderPath & patho)

Do While FileName <> ""
Workbooks.OpenText FileName:=FolderPath & FileName, Origin:= _
        437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=False, FieldInfo:=Array(Array(1, 3), Array(2, 1), Array( _
        3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
   
        ActiveWorkbook.SaveAs FileName:=FolderPath & FileName, _
        FileFormat:=xlCSV, CreateBackup:=False
FileName = Dir
Loop
End Sub

Regards,

Ria · Oct 3, 2014

Somendra Misra said:

Hi Ria,

Just a wild shot, try below code, change the path:

Code:

Option Explicit
Sub test()

Dim FolderPath As String, patho As String, count As Integer, I As Integer, FileName As String, paths As String


FolderPath = "C:\Users\A075970\Desktop\"

patho = "*.txt"
paths = "*.csv"
FileName = Dir(FolderPath & patho)

Do While FileName <> ""
Workbooks.OpenText FileName:=FolderPath & FileName, Origin:= _
        437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=False, FieldInfo:=Array(Array(1, 3), Array(2, 1), Array( _
        3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
  
        ActiveWorkbook.SaveAs FileName:=FolderPath & FileName, _
        FileFormat:=xlCSV, CreateBackup:=False
FileName = Dir
Loop
End Sub

Regards,

Hi Somendra:

Thanks.
1. Loop part is working well. DONE
2. Main part, still does not change date format, attached 2 text files, one original and other one I changed manually (open file in excel/deliminited/select Tab & Comma/next/finish/select column A/right click/format/number/custom/mm/dd/yyyy hh:mm:ss/ok. But this macro is not giving me what I need. missing last :00 (seconds part). Even Nebu added code but still not working.
3. I have one spread sheet (attached) that has macro button on it. As I click it opens file as new workbook. After processing (changing date format), it should close file/sheet/workbook automatically and replace opened/format changed file with original or overwrite on it. At the end, after processing all files, it should just keep open workbook/sheet that has macro on it.

Attached excel file and 2 text files.

Let me know if I can explain different way to make it clear, in case any question.

Thanks for help.

Ria

Ria · Oct 3, 2014

OK, following code is working fine, EXCEPT for date formatting issue is STILL there.
Please anyone solve this problem would be great help.
===================

Code:

Option Explicit
Sub test()

Dim FolderPath As String, patho As String, count As Integer, I As Integer, FileName As String, paths As String


FolderPath = "C:\Users\RK\Desktop\MyDeskTop\NewPC\JM_Hurst\DATA\"

patho = "*.txt"
paths = "*.csv"
FileName = Dir(FolderPath & patho)

Do While FileName <> ""
Workbooks.OpenText FileName:=FolderPath & FileName, Origin:= _
  437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
  ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
  Space:=False, Other:=False, FieldInfo:=Array(Array(1, 3), Array(2, 1), Array( _
  3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True
 
  Dim rngCell As Range
  Range("A:A").Select
  For Each rngCell In Selection
  If IsDate(rngCell.Value) Then
  rngCell.Value2 = Format(rngCell, "MM/dd/yyyy hh:mm:ss..")
  End If
  Next rngCell
 
  'Range("A:A").Select
  'Selection.Replace What:="..", Replacement:="", LookAt:=xlPart, _
  'SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
  'ReplaceFormat:=False
 
  'ActiveWorkbook.SaveAs FileName:=FolderPath & FileName, _
  ' FileFormat:=xlCSV, CreateBackup:=False
 
   ActiveWorkbook.Close SaveChanges:=True


FileName = Dir
Loop
End Sub

================

Thanks

Ria
Edit: Please use CODE tags for VBA codes.

shrivallabha · Oct 3, 2014

Here's one way of working it out. Looping can be added once the code for file processing starts working as intended.

Code:

Option Explicit
Private Sub cmdProcess_Click()
Const ForReading = 1, ForWriting = 2
Dim strFileName As String, strOutFile As String, strOut As String
Dim objFSO As Object, objTxt As Object
Dim varInput As Variant, varArr As Variant
Dim intFF As Integer
Dim i As Long

'\\ Prompt to select file first
On Error Resume Next
With Application.FileDialog(msoFileDialogFilePicker)
  .AllowMultiSelect = False
  .Filters.Add "Text Files", "*.txt", 1
  .Show
  strFileName = .SelectedItems(1)
End With
On Error GoTo 0

'\\ Check if a file has been selected
If Len(strFileName) = 0 Then MsgBox "No file selected!", vbExclamation: Exit Sub

'\\ Read in the contents
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTxt = objFSO.OpenTextFile(strFileName, ForReading)
varInput = Split(objTxt.readall, vbCrLf)

'\\ Create output using read array
strOutFile = Replace(strFileName, ".txt", "_Out.txt")
intFF = FreeFile
Open strOutFile For Output As #intFF
'\\ Fixed header
Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  Print #intFF, strOut
  Next i
Close #intFF

MsgBox "Please check the output file :" & vbCrLf & strOutFile, vbInformation

'\\ Release variables
Set objFSO = Nothing: Set objTxt = Nothing

End Sub

I am attaching the file for your reference.

Ria · Oct 4, 2014

shrivallabha said:

Here's one way of working it out. Looping can be added once the code for file processing starts working as intended.

Code:

Option Explicit
Private Sub cmdProcess_Click()
Const ForReading = 1, ForWriting = 2
Dim strFileName As String, strOutFile As String, strOut As String
Dim objFSO As Object, objTxt As Object
Dim varInput As Variant, varArr As Variant
Dim intFF As Integer
Dim i As Long

'\\ Prompt to select file first
On Error Resume Next
With Application.FileDialog(msoFileDialogFilePicker)
  .AllowMultiSelect = False
  .Filters.Add "Text Files", "*.txt", 1
  .Show
  strFileName = .SelectedItems(1)
End With
On Error GoTo 0

'\\ Check if a file has been selected
If Len(strFileName) = 0 Then MsgBox "No file selected!", vbExclamation: Exit Sub

'\\ Read in the contents
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTxt = objFSO.OpenTextFile(strFileName, ForReading)
varInput = Split(objTxt.readall, vbCrLf)

'\\ Create output using read array
strOutFile = Replace(strFileName, ".txt", "_Out.txt")
intFF = FreeFile
Open strOutFile For Output As #intFF
'\\ Fixed header
Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  Print #intFF, strOut
  Next i
Close #intFF

MsgBox "Please check the output file :" & vbCrLf & strOutFile, vbInformation

'\\ Release variables
Set objFSO = Nothing: Set objTxt = Nothing

End Sub

I am attaching the file for your reference.

Awesome solution.
Thanks shrivallabha.

Here is few little things need to change/add:
1. Loop through a folder and process all files in folder.
2. If file already has been processed then skip it.
3. After formatting date and time, look last line/row in a file only time part.
IF seconds = 00 AND minutes = 00 or 15 or 30 or 45 then do nothing
ELSE select last row and DELETE
4. I am using excel 2003, tried to connect code with button on sheet but can not find the code/macro. Anything special to connect it to button.

Again big thanks making it working.

Ria

Lymm · Oct 4, 2014

Just an idea, i have found in the past for excel 2003 You may have to put your own button on the sheet and then asign the code to it as cmd buttons from later versions dont seem to work with 2003. Hope that works for you.

shrivallabha · Oct 4, 2014

I use Office 2010 which has VBA 7.0 while Excel 2003 uses VBA 6.0. I am not sure if it is the one which is causing you the problem.

I have revised code as per requirements stated in post#15. I have commented the code so it should be easier for you to follow and adapt to suit.

Code:

Option Explicit
Private Sub cmdProcess_Click()
Const ForReading = 1, ForWriting = 2
Dim strFileName As String, strOutFile As String, strOut As String, strFldName As String
Dim objFSO As Object, objTxt As Object, objFld As Object, objFil As Object
Dim varInput As Variant, varArr As Variant
Dim intFF As Integer
Dim i As Long

'\\ Prompt to select file first
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  strFldName = .SelectedItems(1)
End With
On Error GoTo 0

'\\ Check if a folder has been selected
If Len(strFldName) = 0 Then MsgBox "No folder selected!", vbExclamation: Exit Sub

'\\ Build up outer loop
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFld = objFSO.getfolder(strFldName)

For Each objFil In objFld.Files
  strFileName = objFil.Path
  If InStr(strFileName, ".txt") > 0 And _
  InStr(strFileName, "_Out.txt") = 0 Then
  '\\ Read in the contents
  Set objTxt = objFSO.OpenTextFile(strFileName, ForReading)
  varInput = Split(objTxt.readall, vbCrLf)
   
  '\\ Create output using read array
  strOutFile = Replace(strFileName, ".txt", "_Out.txt")
  If Not objFSO.FileExists(strOutFile) Then
  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF
  Else
  MsgBox "Current folder already contains :" & vbCrLf & strOutFile _
  & vbCrLf & "It will not be processed!", vbInformation
  End If
  End If
Next objFil

MsgBox "Finished!" & vbCrLf & "Please check all files ending with _Out.txt", vbInformation
'\\ Release variables
Set objFSO = Nothing: Set objTxt = Nothing

End Sub

This is minimum tested code, you can do further modifications as you need. I am attaching a file in .xls format. Hopefully, it will work at your end as well

Ria · Oct 5, 2014

shrivallabha said:

I use Office 2010 which has VBA 7.0 while Excel 2003 uses VBA 6.0. I am not sure if it is the one which is causing you the problem.

I have revised code as per requirements stated in post#15. I have commented the code so it should be easier for you to follow and adapt to suit.

Code:

Option Explicit
Private Sub cmdProcess_Click()
Const ForReading = 1, ForWriting = 2
Dim strFileName As String, strOutFile As String, strOut As String, strFldName As String
Dim objFSO As Object, objTxt As Object, objFld As Object, objFil As Object
Dim varInput As Variant, varArr As Variant
Dim intFF As Integer
Dim i As Long

'\\ Prompt to select file first
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  strFldName = .SelectedItems(1)
End With
On Error GoTo 0

'\\ Check if a folder has been selected
If Len(strFldName) = 0 Then MsgBox "No folder selected!", vbExclamation: Exit Sub

'\\ Build up outer loop
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFld = objFSO.getfolder(strFldName)

For Each objFil In objFld.Files
  strFileName = objFil.Path
  If InStr(strFileName, ".txt") > 0 And _
  InStr(strFileName, "_Out.txt") = 0 Then
  '\\ Read in the contents
  Set objTxt = objFSO.OpenTextFile(strFileName, ForReading)
  varInput = Split(objTxt.readall, vbCrLf)
  
  '\\ Create output using read array
  strOutFile = Replace(strFileName, ".txt", "_Out.txt")
  If Not objFSO.FileExists(strOutFile) Then
  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF
  Else
  MsgBox "Current folder already contains :" & vbCrLf & strOutFile _
  & vbCrLf & "It will not be processed!", vbInformation
  End If
  End If
Next objFil

MsgBox "Finished!" & vbCrLf & "Please check all files ending with _Out.txt", vbInformation
'\\ Release variables
Set objFSO = Nothing: Set objTxt = Nothing

End Sub

This is minimum tested code, you can do further modifications as you need. I am attaching a file in .xls format. Hopefully, it will work at your end as well

Shrivallabha, FANTASTIC solution. Great thanks for this big help. You are rock star for this code for me.
It works like charm and good thing is, code is way faster than what I have before (I was just trying to put dots together and was seeing excel sheets open/close, changing sheets). But your code does job in a eye blink.

Thanks gains.

Ria

Ria · Oct 5, 2014

shrivallabha said:

I use Office 2010 which has VBA 7.0 while Excel 2003 uses VBA 6.0. I am not sure if it is the one which is causing you the problem.

I have revised code as per requirements stated in post#15. I have commented the code so it should be easier for you to follow and adapt to suit.

Code:

Option Explicit
Private Sub cmdProcess_Click()
Const ForReading = 1, ForWriting = 2
Dim strFileName As String, strOutFile As String, strOut As String, strFldName As String
Dim objFSO As Object, objTxt As Object, objFld As Object, objFil As Object
Dim varInput As Variant, varArr As Variant
Dim intFF As Integer
Dim i As Long

'\\ Prompt to select file first
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
  .AllowMultiSelect = False
  .Show
  strFldName = .SelectedItems(1)
End With
On Error GoTo 0

'\\ Check if a folder has been selected
If Len(strFldName) = 0 Then MsgBox "No folder selected!", vbExclamation: Exit Sub

'\\ Build up outer loop
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFld = objFSO.getfolder(strFldName)

For Each objFil In objFld.Files
  strFileName = objFil.Path
  If InStr(strFileName, ".txt") > 0 And _
  InStr(strFileName, "_Out.txt") = 0 Then
  '\\ Read in the contents
  Set objTxt = objFSO.OpenTextFile(strFileName, ForReading)
  varInput = Split(objTxt.readall, vbCrLf)
  
  '\\ Create output using read array
  strOutFile = Replace(strFileName, ".txt", "_Out.txt")
  If Not objFSO.FileExists(strOutFile) Then
  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF
  Else
  MsgBox "Current folder already contains :" & vbCrLf & strOutFile _
  & vbCrLf & "It will not be processed!", vbInformation
  End If
  End If
Next objFil

MsgBox "Finished!" & vbCrLf & "Please check all files ending with _Out.txt", vbInformation
'\\ Release variables
Set objFSO = Nothing: Set objTxt = Nothing

End Sub

This is minimum tested code, you can do further modifications as you need. I am attaching a file in .xls format. Hopefully, it will work at your end as well

Hi Shrivallabha:
Sorry to bother you again. A little addition to code, before start processing *.txt file, look in folder, if any file output file (e.g _OUT.txt) then DELETE all output files (_OUT.txt), then start processing and create output files. Basically, every time delete all output files and then reprocess all files.
Reason for doing so, sometime we do not get all input files together (sometime we get one input file at a time). With current code, when we process files, it looks output files and if any output file from this new input file exist then it does not process. But this input file is updated one, so should be processed again. To me, it is best to delete previously output files before start processing. Looks

like ugly to keep adding and asking more but that's we realized after doing some deep testing. I am trying to make it work myself but seems just wasting time.

Regards

Ria

shrivallabha · Oct 5, 2014

You can do so by simply removing one check in above code.
OLD CODE:

Code:

  If Not objFSO.FileExists(strOutFile) Then
  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF
  Else
  MsgBox "Current folder already contains :" & vbCrLf & strOutFile _
  & vbCrLf & "It will not be processed!", vbInformation
  End If

REPLACE WITH:

Code:

  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF

This will overwrite the existing file with the latest data. Please check if this is sufficient.

Edit: Notice that I have removed inner if loop condition which tested for existence of a file. Rest of the code is exactly the same.

Ria · Oct 6, 2014

shrivallabha said:

You can do so by simply removing one check in above code.
OLD CODE:

Code:

  If Not objFSO.FileExists(strOutFile) Then
  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF
  Else
  MsgBox "Current folder already contains :" & vbCrLf & strOutFile _
  & vbCrLf & "It will not be processed!", vbInformation
  End If

REPLACE WITH:

Code:

  intFF = FreeFile
  Open strOutFile For Output As #intFF
  '\\ Fixed header
  Print #intFF, "Date  Open  High  Low Close"
  '\\ Start from 2nd row as first row is just header
  For i = 1 To UBound(varInput)
  strOut = Replace(varInput(i), Split(varInput(i), ",")(0), _
  Format(CDate(Split(varInput(i), ",")(0)), "mm/dd/yyyy hh:mm:ss"))
  strOut = Replace(strOut, ",", vbTab)
  If i <> UBound(varInput) Then
  Print #intFF, strOut
  Else
  If Mid(strOut, 18, 2) = "00" And _
  (Abs(Mid(strOut, 15, 2)) Mod 15 = 0) Then
  Print #intFF, strOut
  End If
  End If
  Next i
  Close #intFF

This will overwrite the existing file with the latest data. Please check if this is sufficient.

Edit: Notice that I have removed inner if loop condition which tested for existence of a file. Rest of the code is exactly the same.

EXCELLENT AND THANKS.
Solution you provided does what we need so far. I was trying to use kill to delete files but removing one line of code was game changer.

Thanks

Ria

vba code for custom date & time format

Member

Excel Ninja

Excel Ninja

Excel Ninja

Member

Member

Excel Ninja

Excel Ninja

Excel Ninja

Member

Attachments

Excel Ninja

Member

Attachments

Member

Excel Ninja

Attachments

Member

Member

Excel Ninja

Attachments

Member

Member

Excel Ninja

Member