Macro pour convertir plusieurs fichiers .XLSX ou .XLS en .CSV

Version imprimable

22/07/2019, 14h48
laminosd

Macro pour convertir plusieurs fichiers .XLSX ou .XLS en .CSV

Bonjour tout le monde

je souhaiterai avoir une macro qui me permettrai de convertir plusieurs fichiers en extension (.xlsx,.xls) en un seul fichier .csv tout en choisissant le répertoire de départ des fichiers sources et le répertoire d'arrivé du fichier cible merci pour votre aide.
22/07/2019, 15h25
Igloobel
Citation:

Envoyé par laminosd

Bonjour tout le monde

je souhaiterai avoir une macro qui me permettrai de convertir plusieurs fichiers en extension (.xlsx,.xls) en un seul fichier .csv tout en choisissant le répertoire de départ des fichiers sources et le répertoire d'arrivé du fichier cible merci pour votre aide.

Bonjour,

Voici des briques et de la lecture

- FileDialog
- boucle
- Do .....condition
  loop
- For variable1 TO variable2
  Next

Voici un exemple que j'utilise, mais que vous devez adapter à vos besoins:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
Option Explicit
Public NewFileName
Public myVector As Variant
 
Sub XLSX_creation()
 
On Error GoTo errMngt
 
    Dim filePath As String
    Dim myFile As Variant
    Dim strDate As String
    Dim defaultDate
    Dim myCounter As Long
    Dim ProcessDate As Date
    Dim myMsg As String
 
    With Sheets("Main")    'ligne à adapter/modifier
        .Select
        .Unprotect
    End With
 
    filePath = Range("C5").Value    'ligne à adapter/modifier
    defaultDate = Format(Range("d_Date"), "yyyymmdd")
 
    strDate = InputBox("Please enter the files date (yyyymmdd; example: 20191124)", _
            "Dispo Fiches date", defaultDate)    'ligne à adapter/modifier/supprimer
 
    'check if correct date          'lignes à adapter/modifier/supprimer
    If Len(strDate) < 8 Or Val(strDate) < 8 Then
        MsgBox "Wrong date!", vbOKOnly, "Date input error"
        Application.DisplayAlerts = True
        Sheets("Main").Protect
        Exit Sub
    End If
 
    ProcessDate = DateSerial(CInt(Left(strDate, 4)), CInt(Mid(strDate, 5, 2)), CInt(Right(strDate, 2)))
 
    Sheets("Main").Range("D5") = strDate        'ligne à adapter/modifier
    Range("b5:b100").ClearContents    'ligne à adapter/modifier
    Range("f5:f100").ClearContents    'ligne à adapter/modifier
    Sheets("Main").Range("B5").Select    'ligne à adapter/modifier
 
    filePath = Range("E5").Value + "\"    'ligne à adapter/modifier
    'check if directory exists
    If Not dirExists(filePath) Then
        MsgBox "The path " & filePath & "does NOT exist!", vbOKOnly, "Wrong directory"
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Sheets("Main").Protect    'ligne à adapter/modifier
        Exit Sub
    End If
 
    Dim i           As Integer
    Dim oFSO        As Object
    Dim oFolder     As Object
    Dim oFiles      As Object
 
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(filePath)
    Set oFiles = oFolder.Files
 
    If oFiles.Count = 0 Then MsgBox "No files found under " & filePath, vbOKOnly, "No files": Exit Sub
 
    ReDim myVector(1 To oFiles.Count)
    i = 1
    For Each myFile In oFiles
        myVector(i) = myFile.Name
        i = i + 1
    Next
 
    Sheets("Main").Range("B5").Select    'ligne à adapter/modifier
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
 
    For i = LBound(myVector) To UBound(myVector)
        If Right(myVector(i), 4) = "xlsb" Then  'pour vous ce sera "xls*"
            On Error Resume Next
            NewFileName = Left(myVector(i), InStr(1, myVector(i), ".") - 1) & ".xlsx"  'pour vous ce sera "csv"
            Workbooks.Open Filename:=filePath & myVector(i)
 
            ActiveWorkbook.SaveAs Filename:=filePath & (NewFileName) _
                , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False    'changer cette ligne et y mettre le bon format CSV
            ActiveWindow.Close
 
            With Sheets("Main")    'ligne à adapter/modifier, si nécessaire
                ActiveCell = myVector(i): ActiveCell.Offset(0, 4) = NewFileName
                myCounter = myCounter + 1
                ActiveCell.Offset(1, 0).Activate
            End With
        Else
            SetAttr filePath & myVector(i), vbNormal    'si nécessaire
            Kill filePath & myVector(i)    'si nécessaire
      End If
        On Error GoTo 0
    Next i
 
    myMsg = myCounter & " files have been successfully processed!" & vbLf & vbLf
    If myCounter = 1 Then myMsg = myCounter & " file has been successfully processed!" & vbLf & vbLf
 
    MsgBox myMsg, vbOKOnly, "XLSX files creation"
    Sheets("Main").Protect
 
errMngt_Exit:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub
 
errMngt:
    Workbooks("XLSB_to_XLSX_Transformation.xlsm").Activate    'ligne à adapter/modifier
    Sheets("Main").Protect    'ligne à adapter/modifier
    MsgBox "The procedure 'XLSX_creation' generated an error " & Err, vbOKOnly, "Processing error"
    Resume errMngt_Exit
 
End Sub
 
Function dirExists(myDirectory As String) As Boolean
 
    Dim myFSO As Object
    Set myFSO = CreateObject("Scripting.FileSystemObject")
    dirExists = myFSO.FolderExists(myDirectory)
 
End Function

22/07/2019, 15h33
laminosd

très complexe votre code je ne me retrouve pas
22/07/2019, 15h46
Zekraoui_Jakani

Désolé! vous vouliez une macro .... Mais si trouvez mieux, je suis preneur! Mettez toujours copie de votre fichier en annexe, au cas où quelqu'un veuille bien le traiter (un exemple xls ou xlsx, ainsi que le format désiré en output; masquer ou supprimer les données confidentielles)
22/07/2019, 15h57
Igloobel
Citation:

Envoyé par laminosd

Bonjour tout le monde

je souhaiterai avoir une macro qui me permettrai de convertir plusieurs fichiers en extension (.xlsx,.xls) en un seul fichier .csv tout en choisissant le répertoire de départ des fichiers sources et le répertoire d'arrivé du fichier cible merci pour votre aide.

Bonjour,

Voici des briques et de la lecture

- FileDialog
- boucle
- Do .....condition
  loop
- For variable1 TO variable2
  Next
http://warin.developpez.com/access/fichiers/

A bientôt
22/07/2019, 16h06
Igloobel

voici un lien qui peut aussi t'aider

https://www.developpez.net/forums/d1...chier-xls-csv/

en attendant de voir ton code

bonne journée

1 pièce(s) jointe(s)

Citation:

Envoyé par Zekraoui_Jakani

Désolé! vous vouliez une macro .... Mais si trouvez mieux, je suis preneur! Mettez toujours copie de votre fichier en annexe, au cas où quelqu'un veuille bien le traiter (un exemple xls ou xlsx, ainsi que le format désiré en output; masquer ou supprimer les données confidentielles)

j'ai un bout de code que j'utilise souvent mais qui converti plusieurs fichiers csv en xlsx

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Sub ImporterFichiersR14()
 
Dim A As Long
Dim T As Variant, Fichier As String
Dim Chemin As String, Sep As String, Sortie As String
Dim WholeLine As String, FName As String
 
Application.ScreenUpdating = False
 
W_MON_PROGRAMME = ActiveWorkbook.Name
W_MA_FEUILLE_PARAM = ActiveSheet.Name
 
Chemin = Range("A2")
Sortie = Range("B2")
 
If Dir(Chemin, vbDirectory) = "" Then
        MsgBox "Le répertoire : [" & Chemin & "] n'existe pas"
        Windows(W_MON_PROGRAMME).Activate
        Sheets(W_MA_FEUILLE_PARAM).Select
 
        Exit Sub
 End If
 
If Dir(Sortie, vbDirectory) = "" Then
        MsgBox "Le répertoire : [" & Sortie & "] n'existe pas"
        Windows(W_MON_PROGRAMME).Activate
        Sheets(W_MA_FEUILLE_PARAM).Select
 
        Exit Sub
 End If
 
MK = Range("C2") & ".xlsx"
 
If Dir(Sortie & MK, vbDirectory) <> "" Then Kill Sortie & MK  'suppression
 
 Set newWbk = Application.Workbooks.Add(xlWBATWorksheet) 'Creation d un nveau classeur avec une seule feuille
 newWbk.SaveAs Sortie & MK
 ActiveSheet.Name = "R20"
 
 
'Séparateur du fichier texte
Sep = ";"
 
'Nom de la feuille de calcul où
 
'tu veux importer les données
With Worksheets("R20")
'détermine la première ligne où s'écrira
'la première ligne de données
If .Range("A1") = "" Then
A = 1
Else
A = .Range("A800000").End(xlUp)(2).Row
End If
 
'Début pour boucler sur tous les fichiers .csv
'du répertoire de départ représenté par la variable chemin
 
Fichier = Dir(Chemin & "*.xlsx")
 
Do While Fichier <> ""
FName = Chemin & Fichier
Open FName For Input Access Read As #1
 
'Boucle sur chaque ligne du fichier ouvert
 
While Not EOF(1)
'WholeLine représente le contenu de la ligne lu
 
Line Input #1, WholeLine
'Place dans un tableau T chaque partie de la ligne
 
'coupée par le séparateur d'éléments
 
T = Split(WholeLine, Sep)
 
'Copie dans les cellules de la feuille de calcul
'le contenu du tableau T
 
.Range("A" & A).Resize(, UBound(T) + 1) = T
A = A + 1
Wend
'Ferme le fichier .csv ouvert
Close #1
Fichier = Dir()
Loop
End With
 
Windows(MK).Activate
Sheets("R20").Select
 
 
 
Windows(MK).Close savechanges:=True
 
MsgBox "Traitement terminé fichier R14 crée !", vbInformation
 
End Sub

je voulais avoir le contraire JE VOUS JOINT UN EXTRAIT DES FICHIERS

Voici ce qu'il vous faut:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub Exemple_Conversion_Excel_en_CSV()
    Dim wb As Workbook
    Set wb = Workbooks.Open("C:\temp\testwb.xlsx")
        'mettre ci-dessus le bon répertoire et le bon nom de fichier
 
    wb.SaveAs Filename:="C:\temp\testC.csv", FileFormat:=xlCSV, CreateBackup:=False
      'mettre ci-dessus le bon répertoire et le bon nom de fichier
 
    Application.DisplayAlerts = False
    wb.Close    'si nécessaire/utile
    Application.DisplayAlerts = True
    Set wb = Nothing
End Sub

23/07/2019, 12h13
laminosd

MERCI pour votre réponse ce code transforme un seul fichier excel en csv et moi j'aimerai avoir un code qui balaye tout un répertoire de fichiers xlsx en seul fichier .csv avec des points virgules