Unable to save date in csv file if date is greater than 10

rbnaik

New Member
Joined
Nov 20, 2010
Messages
27
I am having a macro which opens multiple csv files one by one, extracts date from the file name and store this extracted date in a new rightmost column in each file. Then the file is saved in the csv format. All the revised files are then merged in one file as database and then I perform various tasks on the merged file.

My problem is, nowadays, in excel 2010, whenever the date is greater than 10, the date is stored in text format and not in the date format in csv file which I am unable to resolve.
In excel 2007 this problem never occurred.

Can you please help me to correct my code ?

The CSV filenames are like AB01042019.CSV, AB26102019.CSV etc. The file looks like as follows:

CodeNAMEEnglishPhysicsMathschemistry
1A12121614
2B14131618
3C96018
4D1012218
5E12151916
6F139811
7G16161214
8H8121411
9I16111315

<tbody>
</tbody>


The code is as follows:
Code:
Const FileFilter = "*.CSV"
Sub Getfilename()
    Dim fd As FileDialog
    Dim fldpath As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        .Filters.Clear
        If .Show Then
            fldpath = .SelectedItems(1)
        End If
    End With
    
    


If fldpath <> "" Then
    If Len(Dir(fldpath, vbDirectory)) <> 0 Then
      startfolder = fldpath
      Dim filename As String
      filename = Getindfilename(fldpath)
      
    Else
        MsgBox "Invalid Path"
    End If
Else
    MsgBox "Please Enter The Folder Path Containing Workbook"
    Exit Sub
End If






End Sub


Private Function Getindfilename(foldpath As String) As String
    Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet
 
    ExtractFolder foldpath, arr()
 
    On Error Resume Next
    j = -1: j = UBound(arr)
    On Error GoTo 0
 
    For i = 0 To j
        
       ProcessFiles (arr(i))
    Next
End Function
Sub ExtractFolder(Folder As String, arr() As String)
    Dim i As Long, objFS As Object, objFolder As Object, obj As Object
 
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFS.GetFolder(Folder)
 
    For Each obj In objFolder.SubFolders
        ExtractFolder obj.Path, arr()
    Next
 
    For Each obj In objFolder.Files
        If obj.Name Like FileFilter Then
            On Error Resume Next
            i = 0: i = UBound(arr) + 1
            On Error GoTo 0
            ReDim Preserve arr(i)
            arr(i) = objFolder.Path & Application.PathSeparator & obj.Name
            'Debug.Print arr(i)
        End If
    Next
End Sub


Sub ProcessFiles(filename As String)


'   Import the file
    Workbooks.OpenText filename:=filename, _
        Origin:=xlWindows, _
        StartRow:=1, _
        DataType:=xlFixedWidth
    
       
    
    'insert date in last column
    ActiveCell.CurrentRegion.Select
    totalcolumns = Selection.Columns.Count
    totalrows = Selection.Rows.Count
    Range("a1").Select
    Selection.End(xlToRight).Select 'Cursor moves to rightmost column with data
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Date"
    ActiveCell.Offset(1, 0).Range("A1").Select
    
    'get date from filename
    shortfilename = Right(filename, 12)


    'changed so that it can take date format
    filedate = Mid(shortfilename, 3, 2) & "-" _
               & Mid(shortfilename, 5, 2) & "-" _
               & Mid(shortfilename, 7, 2)
    
      
    ActiveCell.FormulaR1C1 = filedate
  
    Range("a1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, totalcolumns).Range("A1").Select
    Selection.Cells(ActiveCell).Value = "x"
    Selection.End(xlUp).Select
    Selection.End(xlUp).Select
    
    Application.CutCopyMode = False
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Columns.AutoFit
    
    


    'This procedure closes all workbooks except active workbook running in this example
    For Each w In Workbooks
        If w.Name <> ThisWorkbook.Name Then
        w.Close savechanges:=True
        End If
    Next w
        


 
Set NewBook = Workbooks.Add
Do
    fName = Application.GetSaveAsFilename
Loop Until fName <> False






    
End Sub
 
Last edited by a moderator:

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Change this

Code:
'changed so that it can take date format
    filedate = Mid(shortfilename, 3, 2) & "-" _
               & Mid(shortfilename, 5, 2) & "-" _
               & Mid(shortfilename, 7, 2)          
    ActiveCell.FormulaR1C1 = filedate

By this
Code:
'changed so that it can take date format
    filedate = Mid(shortfilename, 3, 2) & "-" _
               & Mid(shortfilename, 5, 2) & "-" _
               & Mid(shortfilename, 7, [COLOR=#ff0000]4[/COLOR])          
    ActiveCell[COLOR=#ff0000].value [/COLOR]= [COLOR=#ff0000]cdate(filedate)[/COLOR]

Try and tell me.
 
Last edited:
Upvote 0
Im glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,144
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top