I modified this vba code I found from Kutools that batch converts a folder of XLS and XLSX to CSVs. The problem with the Kutools code was that it didn't handle converting workbooks with multiple sheets.
So I wrote this modification:
Sub Button1_Click()
Dim xObjWB As Workbook
Dim xObjWS As Worksheet
Dim xStrEFPath As String
Dim xStrEFFile As String
Dim xObjFD As FileDialog
Dim xObjSFD As FileDialog
Dim xStrSPath As String
Dim xStrCSVFName As String
Dim intFileCount As Integer
Dim TargetFN As String
On Error GoTo EndHandler
If MsgBox("This macro will convert all XLS and XLSX files from one folder to CSVs in another folder." & Chr(13) & Chr(13) & _
"The program will attempt to close all other workbooks before starting the conversion." & Chr(13) & Chr(13) & _
"This process may take a while. You will be notified when the conversion is finished." & Chr(13) & Chr(13) & _
"Click OK to continue. . .", vbOKCancel, "Read Carefully!") = vbCancel Then
GoTo EndHandler
Else
For Each xObjWB In Workbooks
If xObjWB.Name <> ThisWorkbook.Name Then
xObjWB.Close
End If
Next
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Set xObjFD = Application.FileDialog(msoFileDialogFolderPicker)
xObjFD.AllowMultiSelect = False
xObjFD.Title = "Select a folder which contains Excel files"
If xObjFD.Show <> -1 Then Exit Sub
xStrEFPath = xObjFD.SelectedItems(1) & "\"
Set xObjSFD = Application.FileDialog(msoFileDialogFolderPicker)
xObjSFD.AllowMultiSelect = False
xObjSFD.Title = "Select a folder to locate CSV files"
If xObjSFD.Show <> -1 Then Exit Sub
xStrSPath = xObjSFD.SelectedItems(1) & "\"
xStrEFFile = Dir(xStrEFPath & "*.xls*")
Do While xStrEFFile <> ""
Set xObjWB = Workbooks.Open(Filename:=xStrEFPath & xStrEFFile)
xStrCSVFName = xStrSPath & Left(xStrEFFile, InStr(1, xStrEFFile, ".") - 1)
intFileCount = 0
TargetFN = ""
For Each xObjWS In xObjWB.Sheets
intFileCount = intFileCount + 1
'TargetFN = xStrCSVFName & "_Sheet" & intFileCount & "_" & xObjWS.Name & ".csv"
TargetFN = xStrCSVFName & "_Sheet" & intFileCount & ".csv"
xObjWS.Copy
ActiveWorkbook.SaveAs Filename:=TargetFN, FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
Next
xObjWB.Close SaveChanges:=False
xStrEFFile = Dir
Loop
MsgBox "Process Finished!", , ""
EndHandler:
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I basically added a loop to cycle through each sheet in the in the each workbook to save as separate CSV files.
It works wonderfully, unless there are Chinese characters in the source filenames in which case the macro freezes.
Is there any way to get this to handle Chinese characters in the source filenames?
Thank you in advance!