VBA not cycling through and processing all files in folder

Hi all,

I've been working on some code with the help of a fellow board member to cycle through csv files in a folder and modify the date format from DD/MM/YYYY to YYYY-MM-DD, save each exit and move onto the next.

In my original code the macro would cycle through the files sucessfully and display a message telling the user how many files were processed, but upon opening the csv files in wordpad some of the dates would have switched from YYYYY-MM-DD to YYYY-DD-MM, generally these were where the MM-DD were both under 12, i.e. the month was < December.

This code is below:

Option Explicit
 
 
Sub FixDates()
     
     
    Dim SelectFolder As String
    Dim csvFiles As Variant
    Dim csvWb As Workbook
    Dim x As Integer
    
    Application.DisplayAlerts = False

     
     'browse for folder with csv files
    On Error GoTo FixCsvFiles_Error
    SelectFolder = GetFolder("c:\")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
     'Check user did not cancel folder selection
    If SelectFolder = "" Then
        MsgBox "No Folder Selected - Cannot continue", vbCritical
        End
    End If
     
    SelectFolder = SelectFolder & "\"
    csvFiles = Dir(SelectFolder & "*.csv")
    Do While csvFiles <> ""
         
        Set csvWb = Workbooks.Open(SelectFolder & csvFiles)
        Range("F2").Select
        ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""YYYY-MM-DD"")"
        Selection.AutoFill Destination:=Range("F2:F228")
        Range("F2:F228").Select
        Selection.Copy
        Range("D2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Range("F2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Application.CutCopyMode = False
        Selection.ClearContents
        Range("A229:E300").Select
        Selection.ClearContents
        x = x + 1
        Application.DisplayAlerts = False
        csvWb.Close SaveChanges:=True
        Application.DisplayAlerts = True
        csvFiles = Dir
    Loop
    Application.ScreenUpdating = True
    MsgBox "A total of " & CStr(x) & " files processed", vbInformation
    On Error GoTo 0
    Application.DisplayAlerts = True
    Exit Sub
     
FixCsvFiles_Error:
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FixCsvFiles of Module2"
End Sub
 
 
Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String
     
     
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "BROWSE TO FOLDER LOCATION WITH CSV FILES"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

The improved code provided by Philb1 sucessfully changed the dates in the first csv file processed but doesn't cycle through the remainder of the files in the folder, or display a message telling the user how many files have been processed.

The code is:

Option Explicit
Sub ProperDateFormat()

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    Dim DateCell1 As Range
    Dim rngCell As Range
    Dim TempDateVariable As Date
    Dim lDay As Long
    Dim lMonth As Long
    Dim lYear As Long
    Dim ExternalBook As String
    Dim OpenBkPath As String
    Dim WrkBookOpen As Workbook
    Dim TopRow As Long
    Dim BotRow As Long
    Dim rDateRange As Range
    Dim SelectFolder As String
    
    
'   browse for folder with csv files
            SelectFolder = GetFolder("c:\")
             'Check user did not cancel folder selection
            If SelectFolder = "" Then
                MsgBox "No Folder Selected - Cannot continue", vbCritical
                
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
                End
            End If
     
            SelectFolder = SelectFolder & "\"
            ExternalBook = Dir(SelectFolder & "*.csv")
            OpenBkPath = SelectFolder & ExternalBook
            
'          Set Open Workbook Variable.
            On Error Resume Next ' Returns Error If Not Open
            Set WrkBookOpen = Workbooks(ExternalBook)
            On Error GoTo 0

''        Test If External Workbook Is Open. If Not, Open It as Text file
            If Nothing Is WrkBookOpen Then
                Workbooks.OpenText (OpenBkPath), Origin:=65001, _
                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, 4), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 4), Array(10 _
                , 1), Array(11, 1)), TrailingMinusNumbers:=True, Local:=True
            Else ' if Workbook is Already Open, It Bypasses Open
                Workbooks(ExternalBook).Activate ' Activate it if it's already open
            End If
            
    With Workbooks(ExternalBook)
                TopRow = 2 ' Top Row Of Data On External Worksheet.
                
                BotRow = Workbooks(ExternalBook).Sheets(1).Columns(4).Find(what:="*", LookIn:=xlValues, lookat:=xlPart, _
                    searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False, searchformat:=False).Row

                Set rDateRange = Workbooks(ExternalBook).Sheets(1).Range(Workbooks(ExternalBook).Sheets(1). _
                    Cells(TopRow, 4), Workbooks(ExternalBook).Sheets(1).Cells(BotRow, 4))

'   Set The Top Cells Of Date Ranges
    Set DateCell1 = Workbooks(ExternalBook).Sheets(1).Cells(2, 4) ' Top Cell Of Range
    
    With rDateRange ' Start working only inside the range

        For Each rngCell In rDateRange ' Start Loop
'   Format TempDateVariable & copy DateCell contents into it in the right format
            TempDateVariable = Format(CDate(DateCell1), "dd/mm/yyyy")
'   Get Day Month & Year As Numbers
            lDay = Day(TempDateVariable) ' Get Day as number
            lMonth = Month(TempDateVariable) ' Get Month as number
            lYear = Year(TempDateVariable) '    Get Year as number
'   Clear DateCell1
            DateCell1.Clear
'   Copy the TempDateVariable contents into DateCell in Double format
            DateCell1 = DateSerial(lYear, lMonth, lDay)
'   Change "yyyy/mm/dd" format to "dd/mm/yyyy"
            DateCell1.NumberFormat = "dd/mm/yyyy"
'   Zero TempDateVariable
            TempDateVariable = 0
'   Move down a cell
            Set DateCell1 = DateCell1.Offset(1, 0)
            
        Next rngCell ' Continue loop until the end of the range
        
        If BotRow > 228 Then
        Range(Workbooks(ExternalBook).Sheets(1).Cells(229, 1), _
                Workbooks(ExternalBook).Sheets(1).Cells(BotRow, 5)).Clear
        Else
        End If
        Workbooks(ExternalBook).Close savechanges:=True
        
    End With
    End With
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    End
    
End Sub

Would anyone know what's wrong with the code above and why it's stopped cycling through the files?

I've attached the vba in a workbook for anyone if that's easier.

Regards

David

Hi Rory, that seem to work very well.

Can I ask how you managed to get the format to stay as YYYY-MM-DD even for the lines where the DD-MM could be transposed? In all of my attempts I'd get 2014-04-06 when it should have been 2014-06-04, and the formula "=TEXT(RC[-2],""YYYY-MM-DD"")" looks identical to my original one.

Regardless that's a fantastic result and much appreciated.

Cheers

David

Hi Rory, that seem to work very well.

Can I ask how you managed to get the format to stay as YYYY-MM-DD even for the lines where the DD-MM could be transposed? In all of my attempts I'd get 2014-04-06 when it should have been 2014-06-04, and the formula "=TEXT(RC[-2],""YYYY-MM-DD"")" looks identical to my original one.

Regardless that's a fantastic result and much appreciated.

Cheers

David