VBA Excel: copier et coller à partir de plusieurs fichiers Excel

Version imprimable

11/06/2015, 20h54
LANGAZOU

VBA Excel: copier et coller à partir de plusieurs fichiers Excel

Bonjour,

Je dispose de plusieurs dossiers et sous dossiers qui contiennent plusieurs fichiers Excels ( exemple c:\Desktop\2015\01\fichier1). Chaque sous dossier contient plusieurs fichiers Excel. Je veux creer une macro qui ouvre les fichiers Excel 1 par 1 et copie toutes les lignes et les collent toutes dans un ordre decroissant dans une nouvelle feuille excel. Y'a t-il un moyen Pour fair ca svp?

Merci pour votre aide.

Bonjour,

Ça te prend une Function récursive pour lire tous les répertoires et sous-répertoires.
Voici un exemple

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
Sub SearchFiles()
    ImportFiles "c:\Desktop\2015\"   'Changer au besoin
End Sub
 
Sub ImportFiles(varPath As Variant)
    Dim varFile As Variant
    Dim objColl As Collection
 
    On Error GoTo Erreur
 
    Set objColl = New Collection
 
    If Right(varPath, 1) <> "\" Then varPath = varPath & "\"
 
    varFile = Dir(varPath, vbDirectory + vbArchive)
    Do While varFile <> ""
        'Stocke le répertoire
        If GetAttr(varPath & varFile) = vbDirectory Then
            If Left(varFile, 1) <> "." Then
                objColl.Add varPath & varFile
            End If
 
        'Travailler avec le fichier
        ElseIf LCase(Right(varFile, 3)) = "xls" Or LCase(Right(varFile, 4)) = "xlsx" Then
            'Ouvrir le fichier, le copier et le fermer
            Debug.Print varPath & varFile  'inscrit, pour fins de test, le nom du fichier dans la fenêtre Exécution (Ctrl-G)
        End If
        varFile = Dir
    Loop
 
    For Each varFile In objColl
        ImportFiles varFile
    Next
 
    Set objColl = Nothing
 
    Exit Sub
 
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub

À partir de là, il suffit de trouver la première ligne vide et de copier les données du fichier trouvé.
À la fin, il te restera à trier dans l'ordre qui te convient.

12/06/2015, 04h28
kiki29

Salut, ceci pourrait t'aider ?
12/06/2015, 09h33
LANGAZOU

Bonjour tout le monde,

Merci pour votre réponse.
Mr kiki, le lien que vous m'avez envoyé est inactif.
Mr parmi ,j'ai mis votre code dans un nouveau module d'une nouvelle feuille Excel mais ca n'a pas marché.
12/06/2015, 09h39
kiki29

Salut, faux, le lien est actif, et permet après login de télécharger un fichier Fusion.xlsb, je viens de tester à l'instant
12/06/2015, 09h57
LANGAZOU

j'arrive pas à l'ouvrir peut être c'est dû à l'extension du fichier. pouvez -vous svp m'envoyer un format word ou EXCEL ?.

Merci d'avance.
12/06/2015, 10h03
kiki29

Salut, si tu as Excel 2003 il existe un Pack de compatibilité Microsoft Office pour les formats de fichier Word, Excel et PowerPoint qui te permettra de l'ouvrir et de le sauver en xls.
12/06/2015, 10h15
LANGAZOU

toujours rien ne marche malgré le téléchargement du pack de comptabilité :?
12/06/2015, 10h29
kiki29

Re, une fois de plus faux, je viens de faire le test de sauvegarde en xls puis de lancer cette version sans problèmes.
12/06/2015, 11h21
parmi

Citation:

Envoyé par LANGAZOU

Bonjour tout le monde,

Merci pour votre réponse.
Mr kiki, le lien que vous m'avez envoyé est inactif.
Mr parmi ,j'ai mis votre code dans un nouveau module d'une nouvelle feuille Excel mais ca n'a pas marché.

Qu'est-ce qui n'a pas marché ?
Est-ce que tu comprends le code écrit dans ma macro ?
12/06/2015, 15h05
LANGAZOU

je suis débutant en VBA, j'ai pas bien compri le code désolé.
12/06/2015, 15h39
parmi

Tu dois démarrer avec la macro SearchFiles en t'assurant que le chemin est valide.
La macro ImportFiles va lire chaque répertoire et les classer dans une collection et tourner en boucle pour lire chaque sous-répertoire et chacun de ses fichiers.
J'ai mis les extensions XLS et XSLX, mais on peut ajouter XLSM et autres au besoin...

Si ça ne fonctionne pas, tu dois avoir un message d'erreur.
Dis-nous lequel (description de l'erreur)

Si ça fonctionne tu trouveras les noms des répertoires et fichiers dans la fenêtre Exécution que tu trouveras en tapant Ctrl-G dans l'éditeur VBA

Donc, si ça fonctionne, tu remplaces la ligne Debug.Print par ce que tu veux faire: copier/coller les résultats trouvés, ce qui pourrait faire partie d'une autre discussion éventuellement...
12/06/2015, 15h43
parmi

Et le fichier que tu peux trouver dans le lien de Kiki29 me semble on ne peut plus parfait pour faire ce que tu veux.
Je ne l'ai pas testé, mais à première vue, tu ne peux demander mieux... :king:
12/06/2015, 17h30
LANGAZOU

oui je sais mais le fichier n'a pas marché chez moi malgré plusieurs tentatives. si tu as la possibilité de me l'envoyer en format DOCX ou XLSX ca sera parfait.

Merci beaucoup.
12/06/2015, 17h44
parmi

Si tu parles du fichier de kiki29, ça risque d'être compliqué. Il y a un 2 Userforms avec du code (avec des contrôles nommés de façon particulière), 4 modules,...
12/06/2015, 17h53
LANGAZOU

je ne sais pas pk ca fonctionne pas à mon niveau malgré plusieurs manipulations !
12/06/2015, 19h21
parmi

Qu'est-ce qui ne fonctionne pas ?
Le téléchargement ou l'application comme telle ?
Si c'est l'application, y a-t-il un message d'erreur ? si oui lequel ?
12/06/2015, 22h48
LANGAZOU

Bonsoir,

le code a bien marché sur un autre PC :mouarf: c'est exactement ce que je cherchais. juste une dernière question si vous me le permettez :
qu'est ce que je dois modifier dans le code de kiki29 lorsque je veux copier uniquement des cellules précises (pas une ligne entière) de chaque fichier et les coller successivement ?

Merci pour votre suivi.
12/06/2015, 22h54
parmi

Il faudrait connaître la structure de tes fichiers, quelles cellules tu veux copier.
13/06/2015, 14h22
LANGAZOU

Bonjour cher ''parmi'',

La structure de mes fichiers EXCEL est la même .chaque classeur contient plusieurs feuilles, je veux extraire de ces dernières les éléments suivants :

1) récupération des titres : Date(sheets(1).cells(1,1)), Délai(sheets(1).cells(1,2)),Montant (sheets(2).cells(3,4)), Échéance (sheets(3).cells(10,3))
- Le collage des titres sur la nouvelle feuille se fera horizontalement sur la deuxième Ligne donc on aboutira à 4 colonnes.

2) récupération des valeurs:

- Date existe dans (sheets(1).cells(2,1))
pour chaque date récupérée de chaque classeur, le collage est vertical dans la première colonne "Date" à partir de la cellule (3,1) ...(i,1)

- Délai existe dans (sheets(1).cells(2,2))
pour chaque délai récupéré le collage est vertical dans la deuxième colonne "Délai" à partir de la cellule (3,2) ...(i,2)

- Montant existe dans (sheets(2).cells(4,4))
le collage des montants est vertical dans la troisième colonne "Montant" à partir de la cellule (3,3) ...(i,3)

- Échéance existe dans (sheets(3).cells(11,3))
le collage est vertical dans la 4ème colonne "Échéance" à partir de la cellule (3,4) ...(i,4)

si vous pouvez m'indiquer la démarche uniquement pour une ou deux lignes(colonnes) et je compléterai le reste.

Merci pour votre précieuse aide.
13/06/2015, 14h30
parmi

Est-ce que c'est possible pour toi de joindre un fichier de données (sans données confidentielles) pour qu'on puisse bien voir la structure que tu nous expliques, mais qui semble un peu compliquée à suivre...?
13/06/2015, 19h33
LANGAZOU

3 pièce(s) jointe(s)

Je ne suis pas au boulot pour vous envoyer le fichier exact donc j'ai fait un petit exemple (ci-joint) pour vous faire comprendre le principe.

Pièce jointe 180508 Pièce jointe 180509 Pièce jointe 180510

- Les données que je voudrais récupérer existent dans la 1ère et 2ème PJ ("Exemple" ) sur les feuilles "1", "2" et "3" (en jaune).
- la 3ème pj ("Résultat") résume toutes les données que j'ai récupéré des trois feuilles (Exemple 1 et 2 )" et représente le format requis. A partir de ce principe , et pour chaque classeur on récupère les mêmes données sur les 3 feuilles (à l'aide du macro de kiko29) et les insérer toutes dans l'ordre décroissant et selon le format déjà mentionné.

j’espère que j'étais suffisamment clair. mon but c'est de savoir comment extraire des données à partir des cellules précises et les insérer toutes dans un ordre

Merci beaucoup pour votre intervention.

Je te mets ma façon de procéder qui est pas mal plus simple que l'autre programme que kiki29 t'a suggéré.
Je n'ai pas le temps de tout regarder ce programme et essayer de le comprendre.

Voici donc la façon que j'utiliserais
Copie ce code dans un module de ton classeur Résultats et change le chemin si nécessaire.
Assure-toi que l'onglet où tu veux mettre les données se nomme bien Feuil1, sinon change le nom partout dans le code pour le bon.

Au départ, j'efface les données présentes.
Si tu veux les conserver, enlève la ligne.

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
Sub SearchFiles()
    Dim nbLignes As Long
 
    nbLignes = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
 
    'Efface les données existantes avant de copier
    'Effacer cette ligne si ce n'est pas nécessaire
    Sheets("Feuil1").Range("A2:A" & nbLignes).EntireRow.Delete
 
    ImportFiles "c:\Desktop\2015\"   'Changer au besoin
 
    MsgBox "Terminé"
End Sub
 
Sub ImportFiles(varPath As Variant)
    Dim nbLignes As Long
    Dim varFile As Variant
    Dim objColl As Collection
 
    On Error GoTo Erreur
 
    Set objColl = New Collection
 
    If Right(varPath, 1) <> "\" Then varPath = varPath & "\"
 
    varFile = Dir(varPath, vbDirectory + vbArchive)
    Do While varFile <> ""
        'Stocke le répertoire
        If GetAttr(varPath & varFile) = vbDirectory Then
            If Left(varFile, 1) <> "." Then
                objColl.Add varPath & varFile
            End If
 
        'Travailler avec le fichier
        ElseIf LCase(Right(varFile, 3)) = "xls" Or LCase(Right(varFile, 4)) = "xlsx" Then
            'Détermine la première ligne vide du classeur Résultats
            nbLignes = ThisWorkbook.Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row + 1
 
            'Ouvrir le fichier, copier les données et le fermer
            Workbooks.Open varPath & varFile, , True
 
            ActiveWorkbook.Sheets(1).Range("A2").Copy ThisWorkbook.Sheets("Feuil1").Range("A" & nbLignes)
            ActiveWorkbook.Sheets(1).Range("C5").Copy ThisWorkbook.Sheets("Feuil1").Range("B" & nbLignes)
            ActiveWorkbook.Sheets(2).Range("B4").Copy ThisWorkbook.Sheets("Feuil1").Range("C" & nbLignes)
            ActiveWorkbook.Sheets(3).Range("B4").Copy ThisWorkbook.Sheets("Feuil1").Range("D" & nbLignes)
 
            ActiveWorkbook.Close False
        End If
        varFile = Dir
    Loop
 
    For Each varFile In objColl
        ImportFiles varFile
    Next
 
    Set objColl = Nothing
 
    Exit Sub
 
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Bonjour,

ça marche très bien et c'est facile à modifier ! Merci beaucoup.
juste un petit truc : après avoir tester et ajouter plusieurs données , j'ai voulu faire le tri des lignes selon la date de la plus ancienne au plus récente mais ça n'a pas marché .

ci dessous le code que j'ai ajouté à la fin de ton code:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Range("A2").Select Range(Selection, Selection.End(xlToRight)).Select Selection.AutoFilter Range("A2").Select ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Clear ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _ ("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With

La ligne avec le .Clear cause un problème.

Essaie comme ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Tri()
    Dim nbLignes As Long
 
    nbLignes = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
 
    Sheets("Feuil1").Sort.SortFields.Add Key:=Range("A2:A" & nbLignes), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Feuil1").Sort
        .SetRange Range("A1:D" & nbLignes)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

14/06/2015, 17h31
LANGAZOU

Merci pour ton aide précieuse.