Sub ConvertXLStoCSV()
On Error GoTo erreur
Application.ScreenUpdating = False
Dim curSheet As Worksheet, csvLine As String, csvSeparator As String, myFso, csvFile, i As Integer, j As Integer
Dim strXLSFile As String, strInputFolder As String, strOutputFolder As String
Dim strCSVFile As String
csvSeparator = ";"
'Change Input and Output folders to relevant location
strInputFolder = ThisWorkbook.Path & "\"
strOutputFolder = ThisWorkbook.Path & "\"
Set myFso = CreateObject("Scripting.FileSystemObject")
strXLSFile = Dir(strInputFolder & "*.xls")
Do While strXLSFile <> ""
If Not strInputFolder & strXLSFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name Then
Workbooks.Open strInputFolder & strXLSFile
For Each curSheet In ActiveWorkbook.Sheets
With curSheet
strCSVFile = Left((strXLSFile), InStrRev(strXLSFile, ".") - 1) & "_" & .Name & ".csv"
Set csvFile = myFso.CreateTextFile(Filename:=strCSVFile, overwrite:=True)
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
'initialiser la ligne CSV
csvLine = vbNullString
'boucler sur les 4 colonnes
For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
'créer la ligne
csvLine = csvLine & IIf(csvLine = vbNullString, vbNullString, csvSeparator) & .Cells(i, j).Text
Next j
'écrire la ligne dans le fichier
csvFile.WriteLine csvLine
Next i
csvFile.Close
End With
Next curSheet
ActiveWorkbook.Close False
End If
strXLSFile = Dir
Loop
erreur:
Application.ScreenUpdating = True
End Sub