Discussion :

[Docmarti]

Bonjour Daniel.

Ce n'est pas mon code. C'est le tien que j'ai seulement testé et donc débuggé.
Et il ne permet pas plusieurs dossiers, il me semble.

Je ne travaille jamais avec FileSystemObject.
Mais il faudra que je m'y soumette un jour.

Cordialement

Docmarti

[Marc-L]

Salut Docmarti !

FileSystemObject a l'avantage d'être riche en fonctions diverses
mais je l'évite car souvent bien plus lent que les instructions internes au VBA …

[Daniel.C]

Bonjour,

@ Docmarti :
Pas réveillé, ce matin. Qu'est-ce que tu as modifié ?
@ Marc-L :
Docmarti a seulement modifié mon code le "FileSystemObject" est de moi. Je l'ai utilisé parce qu'il a été question un moment de fouiller dans les sous-dossiers.

[Invité]

Code Module de classe ExplorateurWindows :

Sélectionner tout - Visualiser dans une fenêtre à part

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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
 Public EnteteTxt As String
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe(Repertoires As String) As Boolean
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = Fso.FolderExists(Repertoires)
Set Fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
Dim Fso As Object
Dim Rep As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = Fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim T
Dim R As String
Dim I As Long
R = ""
T = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(T)
    If Trim("" & T(I)) <> "" Then
        R = R & Trim("" & T(I)) & "\"
        If Repertoires_Existe(R) = False Then Fso.CreateFolder R
    End If
Next
Set Fso = Nothing
End Sub
 
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFolder Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Sub Deplace_Repertoire(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFolder Source, Destination
Set Fso = Nothing
End Sub
 
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFolder DelRepertoire, True
Set Fso = Nothing
End Sub
'Taille d'un Fichier
Public Function Taille_Fichier(Fichier)
Dim Fso As Object
Dim Fich As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fich = Fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = Fso.FileExists(Fichier)
Set Fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = Fso.GetBaseName(Fichier)
Set Fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = Fso.GetExtensionName(Fichier)
Set Fso = Nothing
End If
End Function
 
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFile Source, Destination
Set Fso = Nothing
End Sub
 
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier As String)
If Fichier_Exist(DelFichier) = True Then
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFile DelFichier, True
Set Fso = Nothing
End If
End Sub
Private Function AppendTxt(sFile, sText)
Dim Fso, NewFichier
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(sFile, 8)
 
NewFichier.Write sText
NewFichier.Close
 
Set NewFichier = Nothing
Set Fso = Nothing
 
End Function
 
Public Sub FichierLog(sFile, TXT)
Dim FichierLog, Fso
 
FichierLog = sFile
 
 
''CreerPath FichierLog
 
Set Fso = CreateObject("Scripting.FileSystemObject")
 
If Fso.FileExists(FichierLog) = False Then EnteteFichier FichierLog
 
AppendTxt FichierLog, TXT
 
Set Fso = Nothing
End Sub
 
Private Sub EnteteFichier(Fichier)
Dim TXT, Fso, NewFichier
 
 
 'WScript.Echo Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write EnteteTxt
NewFichier.Close
 
 
Set NewFichier = Nothing
Set Fso = Nothing
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Sub test()
Dim WinXp As New ExplorateurWindows
WinXp.Creer_Repertoires "C:\toto\toto\toto" 'Céer les répertoire en cascade.
WinXp.EnteteTxt = "Champ1;Champ2;Champ3" & vbCrLf
WinXp.FichierLog "C:\toto\toto\toto\toto.csv", Chr(34) & [A1] & Chr(34) & ";" & Chr(34) & [B1] & Chr(34) & ";" & Chr(34) & [C1] & Chr(34) & vbCrLf
End Sub

tu veux que chaque colonnes soient entre guillemet ou que les texte pas le numérique et les date?

[Marc-L]

@ Marc-L :
Docmarti a seulement modifié mon code le "FileSystemObject" est de moi. Je l'ai utilisé parce qu'il a été question un moment de fouiller dans les sous-dossiers.

Salut Daniel !

C'est juste pour dire que l'on peut sans passer, surtout pour la recherche de sous-dossiers car là c'est vraiment lent
comparativement à la fonction Dir même si cette dernière est plus retorse à programmer …

[Docmarti]

Bonjour,

@ Docmarti :
Pas réveillé, ce matin. Qu'est-ce que tu as modifié ?

@Daniel
J'ai modifié ces 3 lignes :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
If LCase(Right(F.Name, 5)) = ".xlsx" Then
If LCase(Right(F.Name, 4)) = ".xls" Then
 
                    Open Dossier & "\" & Left(Wbk.Name, Len(Wbk.Name) - 5) & "-" & Sh.Name & ".csv" For Output As #1
                    Open Dossier & "\" & F.Name & "-" & Sh.Name & ".csv" For Output As #1
 
                    For Each c In Range([A1], Cells(Rows.Count, 1).End(xlUp))
                    For Each c In Sh.Range(Sh.Cells(1, 1), Sh.Cells(Rows.Count, 1).End(xlUp))
 
                        For Each x In Range(Cells(c.Row, 1), Cells(c.Row, Columns.Count).End(xlToLeft))
                        For Each x In Sh.Range(Sh.Cells(c.Row, 1), Sh.Cells(c.Row, Columns.Count).End(xlToLeft))

[Docmarti]

Bonjour rdurupt

Ton code est intéressant mais il est dangereux de mettre la procédure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Sub Supprimer_Repertoire(DelRepertoire As String)

entre les mains d'un programmeur débutant.


Cordialement

Docmarti

[Invité]

c'est une classe que j'ai développé pour mes propre besoin que je met à disposition.

il est vrai qu'il faut faire gaffe! ceci dit elle est quand même explicite!

[Daniel.C]

@Docmarti :
1. J'avais cru comprendre qu'il s'agissait uniquement de fichiers .xlsx ?
2. j'ai juste sorti l'extension initiale du nom du fichier csv.
3. et 4. OK là il y a un bug; j'avais juste testé avec le classeur fourni qui ne comporte qu'une feuille...

[karido-74]

bonjour,

super çà marche bien , je te remercier bcp ,il y a un petit détail les cellules avec format spéciaux exemple (001) une fois le fichier Excel est converti redeviens (1)

cordialement

[Invité]

bonjour,

super çà marche bien , je te remercier bcp ,il y a un petit détail les cellules avec format spéciaux exemple (001) une fois le fichier Excel est converti redeviens (1)

cordialement

[karido-74]

Bonjour ;

j'ai utiliser cette macro , elle ma permet de parcourir qu’un seule dossier, c'est déjà très bien pour moi vu que j'ai 21 dossiers a traité mais il reste le problème que j'ai signalé dans le message avant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Daniel_ExportDossierCSV()
 
    Dim Enrgt As String, FSO As Object, F As Object, Dossier As String
    Dim Repertoire As FileDialog, Sh As Worksheet, Wbk As Workbook
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
    For Each F In FSO.getfolder(Repertoire.SelectedItems(1)).Files
        Dossier = Repertoire.SelectedItems(1)
 
        If LCase(Right(F.Name, 4)) = ".xls" Then
            Set Wbk = Workbooks.Open(F.Path)
 
            For i = 1 To Wbk.Worksheets.Count
                Set Sh = Wbk.Worksheets(i)
                Debug.Print Dossier & "\" & F.Name & "-" & Sh.Name & ".csv"
 
                If Application.CountA(Sh.Cells) > 0 Then
 
                    Close #1
                    Open Dossier & "\" & F.Name & "-" & Sh.Name & ".csv" For Output As #1
                    For Each c In Sh.Range(Sh.Cells(1, 1), Sh.Cells(Rows.Count, 1).End(xlUp))
                        Enrgt = ""
                        For Each x In Sh.Range(Sh.Cells(c.Row, 1), Sh.Cells(c.Row, Columns.Count).End(xlToLeft))
                            Enrgt = Enrgt & """;""" & x.Value
                        Next x
                        Enrgt = Right(Enrgt, Len(Enrgt) - 2) & """"
                        Print #1, Enrgt
                    Next c
                    Close #1
                End If
            Next i
            Wbk.Close , False
 
        End If
    Next F
 
End Sub

[Invité]

si ta cellule contient 1 et quelle est formaté pour obtenir 001 x.value te donnera 1;

il faut utiliser x.text pour enregistrer la valeur tel quelle visible dans excel.

[karido-74]

avant la conversion j'ai des céllules avec des formats spéciaux la seule qui pose portable c la cellules qui a (001) une fois la conversion faite vers csv la cellules redevienne 1 au lieux de 001

cordialement

[Invité]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Enrgt = Enrgt & """;""" & x.Text

http://www.developpez.net/forums/d14...s/#post7671516

[karido-74]

la je comprend rien du tout tout a l'heure j'ai exécuter la macro j'ai un dossier ou il y a 3 fichiers excel (les deux premiers il y a deux feuille chacune ) donc en tout quand j'ai lancer la macro le résultat 5 fichiers csv et la quand j'ai changer
et la la macro elle s’exécute sur un dossier mais pas de résultats

[Daniel.C]

Quel est le nom des fichiers ?

[karido-74]

BD.xlsx

[Daniel.C]

Pour traiter les fichiers .xlsx, il faut remplacer la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If LCase(Right(F.Name, 4)) = ".xls" Then

par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If LCase(Right(F.Name, 5)) = ".xlsx" Then

Si tu veux traiter les deux :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If LCase(Right(F.Name, 4)) = ".xls" Or LCase(Right(F.Name, 5)) = ".xlsx" Then

[Invité]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If LCase(Right(F.Name, 4))  Like  "*xls*" Then