Convertir plusieurs .csv en .xlsx

Bonjour à tous,

Je souhaite convertir des .csv en .xlsx en masse.

Voici la macro utilisée:

Option Explicit

Dim Nb As Long
Const sExtension As String = "csv"
Const sNewExtension As String = "xlsx"
Const TypeFichier = "csv"

Private Sub ChangerExtensionFichiers(ByVal sDossier As String, bSousDossier As Boolean)
Dim FSO As Object
Dim Dossier As Object
Dim sFichier As String, F As String
Dim Pos As Long, i As Long, sExt As String
Dim TFichier() As String
Dim sNom As String

    Application.ScreenUpdating = False
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sDossier)

    TFichier = Split(TypeFichier, ";")

    sFichier = Dir$(sDossier & "\*.*")

    Do While Len(sFichier) > 0
        F = FSO.GetFileName(sFichier)
        For i = LBound(TFichier) To UBound(TFichier)
            If UCase(sFichier) <> UCase(ThisWorkbook.Name) Then
                Pos = InStr(F, TFichier(i))
                sExt = FSO.GetExtensionName(F)
                If Pos > 0 And UCase(sExt) = UCase(sExtension) Then
                    sNom = Left$(F, Len(F) - Len(sExt))

                    Workbooks.Open Filename:=sDossier & "\" & sFichier
                    Application.DisplayAlerts = False
                    ActiveWorkbook.SaveAs Filename:=sDossier & "\" & sNom & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                    ActiveWorkbook.Close
                    Application.DisplayAlerts = True

                    Nb = Nb + 1
                End If
            End If
        Next i
        sFichier = Dir$()
        Application.StatusBar = Nb
    Loop

    If bSousDossier Then
        For Each Dossier In Dossier.SubFolders
            ChangerExtensionFichiers Dossier.Path, True
        Next Dossier
    End If

    Application.ScreenUpdating = True
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub

Sub SelDossier()
Dim sStr As String
    sStr = Replace(TypeFichier, ";", "   ")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Conversion fichiers ( " & sStr & " ) de " & UCase(sExtension) & " en " & UCase(sNewExtension)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        Nb = 0
        If .SelectedItems.Count > 0 Then
            DoEvents
            ChangerExtensionFichiers .SelectedItems(1), True
        End If
    End With
End Sub

Problème, je conserve les ";" dans mon fichier converti alors que je souhaiterais la création des colonnes et lignes correspondantes...

Est-il possible de réaliser cette opération?

Merci d'avance

fifou

J'ai trouvé!!

Si jamais cela intéresse certains :

J'ai trouvé quelque chose d'existant en rajoutant mes conditions :

Sub CSVtoXLS()
    Dim xFd As FileDialog
    Dim xSPath As String
    Dim xCSVFile As String
    Dim xWsheet As String
    Application.DisplayAlerts = False
    Application.StatusBar = True
    xWsheet = ActiveWorkbook.Name
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    xFd.Title = "Choisissez le dossier :"
    If xFd.Show = -1 Then
        xSPath = xFd.SelectedItems(1)
    Else
        Exit Sub
    End If
    If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
    xCSVFile = Dir(xSPath & "*.csv")
    Do While xCSVFile <> ""
        Application.StatusBar = "Converting: " & xCSVFile
        Workbooks.Open Filename:=xSPath & xCSVFile
        Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
        ActiveWorkbook.SaveAs Replace(xSPath & xCSVFile, ".csv", ".xlsx", vbTextCompare), xlWorkbookDefault
        ActiveWorkbook.Close
        Windows(xWsheet).Activate
        xCSVFile = Dir
    Loop
    Application.StatusBar = False
    Application.DisplayAlerts = True
End Sub