Convert to CSV VBA code is skipping files in selected folder

[leglenn]

Hello,
I have the following code, which runs correctly, however, it is skipping every other file in my directory. There are 66 files and it ends up converting 34 (1 file has 2 sheets that are converted as separate csv's). Does anyone know why it would be doing that?


Sub SaveToCSVs()
Dim fDir As String
Dim wb As Workbook
Dim wS As Worksheet
Dim csvWs As String, csvWb As String
Dim extFlag As Long '0 = .xls & 1 = .xlsx extension types
Dim fPath As String
Dim sPath As String, dd() As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
fPath = "C:\Data\*.*"


sPath = "C:\Data"
fDir = Dir(fPath)
extFlag = 2
Do While (fDir <> "")
If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then
extFlag = 0
Else
extFlag = 2
End If
On Error Resume Next
If extFlag = 0 Then
fDir = Dir
Set wb = Workbooks.Open(sPath & fDir)
csvWb = wb.Name
dd = Split(csvWb, ".")
For Each wS In wb.Sheets
If Right(wS.Name, 8) = "Criteria" Then
'Do nothing
Else
wS.SaveAs sPath & dd(0) & "-" & wS.Name & ".csv", xlCSV
End If
Next wS
wb.Close False
Set wb = Nothing
fDir = Dir
On Error GoTo 0
End If
Loop
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[leglenn]

Here is an example of my directory after running:

Case_Note_Detailed_Report.xls
Case_Note_Detailed_Report-Report Result-1.csv
Case_Note_Detailed_Report1.xls
Case_Note_Detailed_Report2.xls
Case_Note_Detailed_Report2-Report Result-1.csv
Case_Note_Detailed_Report3.xls

 

[John_w]

I think the Dir function is getting confused because it is looping through the files in a folder at the same as new files are being created in the same folder. The solution is to either create the new files in a different folder, or have the Dir loop write the files to a dynamic array and then loop through the array.

 

[leglenn]

I think the Dir function is getting confused because it is looping through the files in a folder at the same as new files are being created in the same folder. The solution is to either create the new files in a different folder, or have the Dir loop write the files to a dynamic array and then loop through the array.

I tried that, which put the new files into the new directory, however it still did only have of the originals. Any other ideas?

Sub SaveToCSVs()
Dim fDir As String
Dim wb As Workbook
Dim wS As Worksheet
Dim csvWs As String, csvWb As String
Dim extFlag As Long '0 = .xls & 1 = .xlsx extension types
Dim fPath As String, newPath As String
Dim sPath As String, dd() As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
fPath = "C:\Data\*.*"


sPath = "C:\Data"
newPath = "C:\Data\CSV"
fDir = Dir(fPath)
extFlag = 2
Do While (fDir <> "")
If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then
extFlag = 0
Else
extFlag = 2
End If
On Error Resume Next
If extFlag = 0 Then
fDir = Dir
Set wb = Workbooks.Open(sPath & fDir)
csvWb = wb.Name
dd = Split(csvWb, ".")
For Each wS In wb.Sheets
If Right(wS.Name, 8) = "Criteria" Then
'Do nothing
Else
wS.SaveAs newPath & dd(0) & "-" & wS.Name & ".csv", xlCSV
End If
Next wS
wb.Close False
fDir = Dir
On Error GoTo 0
End If
Loop
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[leglenn]

Note: There are 66 *.xls files that should be converted in the C:\Data directory. It is skipping every other one in sort order.

 

[John_w]

I tried that, which put the new files into the new directory, however it still did only have of the originals. Any other ideas?

With your latest code you are only saving new files in the \CSV\ subfolder, so it wouldn't contain the originals. Use the FileCopy command to copy the original files to the subfolder. Also make sure the folder path in the sPath and newPath strings end with a back slash.

PS - please put code inside CODE tags - click the # icon in the message editor.

 

[leglenn]

With your latest code you are only saving new files in the \CSV\ subfolder, so it wouldn't contain the originals. Use the FileCopy command to copy the original files to the subfolder. Also make sure the folder path in the sPath and newPath strings end with a back slash.

PS - please put code inside CODE tags - click the # icon in the message editor.

If I copy the originals into the newPath folder, then it is just like my original folder, which is not necessary. sPath and newPath both end in a backslash in my code. I did find the error though - see below in GREEN. The code was doing fDir twice.

Sub SaveToCSVs()
    Dim fDir As String
    Dim wb As Workbook
    Dim wS As Worksheet
    Dim csvWs As String, csvWb As String
    Dim extFlag As Long '0 = .xls & 1 = .xlsx extension types
    Dim fPath As String, newPath As String
    Dim sPath As String, dd() As String
    'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    fPath = "C:\Data\*.*"


    sPath = "C:\Data\"
    newPath = "C:\Data\CSV\"
    fDir = Dir(fPath)
    extFlag = 2
    Do While (fDir <> "")
        If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then
            extFlag = 0
        Else
            extFlag = 2
        End If
        On Error Resume Next
        If extFlag = 0 Then
[COLOR=#008000]            'fDir = Dir since Dir was done above, it was moving to the next file[/COLOR]
            Set wb = Workbooks.Open(sPath & fDir)
            csvWb = wb.Name
            dd = Split(csvWb, ".")
            For Each wS In wb.Sheets
                If Right(wS.Name, 8) = "Criteria" Then
                    'Do nothing
                Else
                    wS.SaveAs newPath & dd(0) & "-" & wS.Name & ".csv", xlCSV
                End If
            Next wS
            wb.Close False
            fDir = Dir
            On Error GoTo 0
        End If
    Loop
'Reset Macro Optimization Settings
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub