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

[rbnaik]

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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Code[/TD]
[TD]NAME[/TD]
[TD]English[/TD]
[TD]Physics[/TD]
[TD]Maths[/TD]
[TD]chemistry[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]A[/TD]
[TD]12[/TD]
[TD]12[/TD]
[TD]16[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]B[/TD]
[TD]14[/TD]
[TD]13[/TD]
[TD]16[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]C[/TD]
[TD]9[/TD]
[TD]6[/TD]
[TD]0[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]D[/TD]
[TD]10[/TD]
[TD]12[/TD]
[TD]2[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]E[/TD]
[TD]12[/TD]
[TD]15[/TD]
[TD]19[/TD]
[TD]16[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]F[/TD]
[TD]13[/TD]
[TD]9[/TD]
[TD]8[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]G[/TD]
[TD]16[/TD]
[TD]16[/TD]
[TD]12[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]H[/TD]
[TD]8[/TD]
[TD]12[/TD]
[TD]14[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]I[/TD]
[TD]16[/TD]
[TD]11[/TD]
[TD]13[/TD]
[TD]15[/TD]
[/TR]
</tbody>[/TABLE]


The code is as follows:

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

 

[rbnaik]

Hi,
Can anybody help ?

 

[DanteAmor]

Change this

'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

'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.

 

[rbnaik]

Sorry for late reply... this worked perfectly...

 

[DanteAmor]

Im glad to help you. Thanks for the feedback.