Discussion :

[paul311]

Bonjour à tous,

Après avoir parcouru le forum une dizaines de fois je n'arrive toujours pas à régler mon problème. J'ai essayé certains code que j'ai trouvé mais qui ne s'adaptent pas à mon projet ou qui ne marchent pas. Je commence donc à vraiment désespérer.

Voici mon problème:
J'aimerai importer les données de plusieurs fichier csv ( séparés par une virgule) qui sont dans le même dossier, dans un nouveau fichier excel dans la Feuil1 et cela en utilisant un macro.
Les données contenues dans les fichiers sont réparties exactement de la même manières ( les même titres, de la colonne A à la colonne J ).
Donc le but est de pouvoir superposer ces données les unes après les autres dans le nouveau classeur sans évidemment copier les titres contenues dans la ligne 1.

Merci à l'avance pour vote aide, je suis un débutant en VBA donc j'aimerai avoir le code pour cette macro et si possible avoir quelques commentaires avec.

Bien à vous.

Paul

[kiki29]

Salut, voir ceci
une re recherche

[paul311]

Merci pour ta réponse aussi rapide mais j'ai déjà parcouru ce lien qui ne m'aide pas vraiment dans ma démarche. Je sais ma demande est un peu spécifique mais j'ai tout essayé avant d'ouvrir cette discussion.

Merci

[kiki29]

Salut, petit rappel de la charte :

Souvenez-vous que les contributeurs sont des bénévoles et ne sont pas là pour vous amener la solution toute faite

Cependant un exemple à adapter à ton contexte et livré en l'état, ici il fonctionne parfaitement.

• Basculer Local:=True en Local:=False dans Lire(ByVal sNomFichier As String)

• ShParam est le CodeName de la feuille ou 2 boutons sont placés :
• L'un permet de sélectionner le dossier contenant les csv, l'affecter à SelDossier
• L'autre permet de sauver les données fusionnées de la/les feuilles Datas_xxx, l'affecter à SaveDatas

• La plage à copier est à adapter :
Wkb.Sheets(1).Range("A1:Y" & LastRow).Copy dans Lire(ByVal sNomFichier As String)

• Si version Excel >= 2007 dans SaveDatas Changer

sNomFichier = Ws.Name & "_" & sDateSauvegarde & ".xls"

par

sNomFichier = Ws.Name & "_" & sDateSauvegarde & ".xlsx"

ActiveWorkbook.SaveAs Filename:=sCheminDossierSauvegarde & "\" & sNomFichier, FileFormat:=xlNormal

par

ActiveWorkbook.SaveAs Filename:=sCheminDossierSauvegarde & "\" & sNomFichier, FileFormat:=xlOpenXMLWorkbook

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
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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
Option Explicit
 
Dim TabFichiers() As String
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim iNumDatas As Long
Dim iRow As Long, Cpt As Long, NbFichiers As Long, sNum As String, sNomAct As String
Const sDossierSauvegarde As String = "Sauvegarde Datas"
 
Const iRowDep As Long = 1
Const sNomFeuillesDatas As String = "Datas_"
Const TypeFichier As String = "csv"
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Private Sub DelFeuilles()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If (Ws.Name <> ShParam.Name) And (Ws.Name Like sNomFeuillesDatas & "###") Then
            Application.DisplayAlerts = False
            Ws.Delete
            Application.DisplayAlerts = True
        End If
    Next Ws
End Sub
 
Private Sub Init()
    iRow = iRowDep: Cpt = 0: NbFichiers = 0: iNumDatas = 0: sNum = ""
    DelFeuilles
End Sub
 
Private Sub LectureFichiers()
Dim i As Long
    For i = 1 To UBound(TabFichiers)
        Lire TabFichiers(i)
        Cpt = Cpt + 1
    Next i
End Sub
 
Private Sub Lire(ByVal sNomFichier As String)
Dim FSO As Object
Dim Fichier As String
Dim LastRow As Long
Dim Wkb As Workbook, sNomSh As String
Dim LastRowPaste As Long
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Fichier = FSO.GetFileName(sNomFichier)
 
    Application.DisplayAlerts = False
    Set Wkb = Application.Workbooks.Open(sNomFichier, Local:=True)
    Application.DisplayAlerts = True
 
    LastRow = Wkb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    LastRowPaste = iRow + LastRow - iRowDep
 
    If LastRowPaste > ShParam.Rows.Count Or sNum = "" Then
        iRow = iRowDep
        sNomSh = ThisWorkbook.ActiveSheet.Name
        ThisWorkbook.Sheets.Add
 
        iNumDatas = iNumDatas + 1
        sNum = Format(iNumDatas, "000")
 
        With ThisWorkbook
            .ActiveSheet.Name = sNomFeuillesDatas & sNum
            .ActiveSheet.Move After:=.Worksheets(sNomSh)
            .ActiveSheet.Range("A" & iRow).Select
        End With
        sNomAct = sNomFeuillesDatas & sNum
    End If
 
    ' Plage à Copier et donc à adapter
    Wkb.Sheets(1).Range("A1:Y" & LastRow).Copy
    ThisWorkbook.Worksheets(sNomAct).Range("A" & iRow).PasteSpecial xlPasteValues
 
    iRow = iRow + LastRow
 
    With Application
        .StatusBar = "Lecture Fichiers : " & Cpt + 1 & " / " & NbFichiers
        .CutCopyMode = False
    End With
 
    Wkb.Close False
    Set FSO = Nothing
End Sub
 
Private Sub ListeFichiersDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        sPath = sChemin & "\" & Fichier
        If Fichier <> ThisWorkbook.Name And UCase(TypeFichier) = UCase(FSO.GetExtensionName(Fichier)) Then
            NbFichiers = NbFichiers + 1
            ReDim Preserve TabFichiers(1 To NbFichiers)
            TabFichiers(NbFichiers) = sPath
        End If
        Fichier = Dir$()
    Loop
 
    If bInclureSousDossiers Then
        For Each Dossier In Dossier.SubFolders
            ListeFichiersDossier Dossier.Path, True
        Next Dossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub MepFeuilles()
Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
        If (Ws.Name <> ShParam.Name) And (Ws.Name Like sNomFeuillesDatas & "*") Then
            With Ws
                .Activate
                .Tab.ColorIndex = 19
                .Columns("A:Y").Columns.AutoFit
                .Range("A1").Select
            End With
        End If
    Next Ws
End Sub
 
Private Sub MepFinale()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    With ShParam
        .Activate
        .Range("D1").Select
    End With
End Sub
 
Sub SaveDatas()
Dim Ws As Worksheet
Dim Wkb As Workbook
Dim sDateSauvegarde As String
Dim sCheminDossierSauvegarde As String
Dim sNomFichier As String
 
    sCheminDossierSauvegarde = ThisWorkbook.Path & "\" & sDossierSauvegarde
    CreationDossier sCheminDossierSauvegarde
 
    Application.ScreenUpdating = False
    For Each Ws In ThisWorkbook.Worksheets
        sDateSauvegarde = Format(Now, "yyyymmdd_hhmmss")
        If Ws.Name Like sNomFeuillesDatas & "###" Then
            ' Datas_xxx_aaaammjj_hhmmss.xls
            sNomFichier = Ws.Name & "_" & sDateSauvegarde & ".xls"
 
            Set Wkb = Workbooks.Add
            Ws.UsedRange.Copy Wkb.Worksheets(1).Range("A1")
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=sCheminDossierSauvegarde & "\" & sNomFichier, FileFormat:=xlNormal
            Application.DisplayAlerts = True
            ActiveWindow.Close
        End If
    Next Ws
 
    ShParam.Range("D1").Select
    Application.ScreenUpdating = True
    Set Wkb = Nothing
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            QueryPerformanceCounter Dep
            Init
            DoEvents
            Application.ScreenUpdating = False
 
            ' Recherche récursive ou non dans les sous dossiers : True/False
            '   ici à False et donc se limitant au dossier racine sélectionné
            ListeFichiersDossier .SelectedItems(1), False
 
            If NbFichiers = 0 Then
                MepFinale
                Application.ScreenUpdating = True
                MsgBox "Pas de fichier csv dans " & .SelectedItems(1), vbOKOnly + vbInformation, "Infos"
                ShParam.Range("D1").Select
                Exit Sub
            End If
 
            LectureFichiers
            MepFeuilles
            MepFinale
 
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
 
            With Application
                .ScreenUpdating = True
                .StatusBar = "Terminé : Fichiers  " & Cpt & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
            End With
        End If
 
        With ShParam
            .Activate
            .Range("D1").Select
        End With
    End With
End Sub

[paul311]

Merci beaucoup pour ton aide.