XL 2013 Compiler les données de 500 fichiers dans un seul fichier

[zozo2502]

Bonjour à tous,
Je suis nouveau sur le forum, et j'ai besoin de votre aide.
En effet, j'ai besoin d'extraire des données (des adresses mails) de 500 fichiers excel pour les enregistrer dans un seul fichier et donc créer une database mailing.
1/ les fichiers ont des noms différents et sont sauvegardés dans un même répertoire
2/ la feuille dans laquelle je dois récupérer les fichiers porte toujours le même nom (sheet1)

Les feuilles ne comportant pas trop de lignes, j'aimerais créer une base globale avec tous ces fichiers, et faire après tes TCD pour récupérer mes données.
Le problème c'est que je ne peux pas copier coller 500 fichiers; j'aimerais un code de macro.

En vous remerciant de votre aide.

zozo2502

 

[job75]

Bonjour zozo2502, bienvenue sur XLD,

Je suppose que les adresses mails sont toujours dans la même colonne, laquelle ?

Et quelle peut être la plage maximum qui les contient dans les feuilles sources (exemple H2:H100) ?

A+

 

[zozo2502]

Bonjour @job75 les adresses mails sont toujours en colonnes V et AH.
Les fichiers ne comportant pas trop de données je veux consolider toutes les colonnes si possible.
La plage est donc de A2:AY20 si on ne prend pas les entêtes de colonne.

Merci de ton aide.

 

[Robert]

Bonjour Zozo, bonjour le forum,

En gros ça donne ça :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CS As worksbook 'déclare la variable CD (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xls*") 'définit le premier fichier excel F ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe des fichiers F
    Set CS = Workbooks(CA & F).Open 'définit la classeur source CS en l'ouvrant
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    OS.Range("A1").CurrentRegion.Copy DEST 'copie les cellule de la plage A1 étendue aux cellules adjacentes
    CS.Close False 'ferme le classeur source sans l'enregistrer
    F = Dir 'définit le fichier excel suivant ayant ayant CA comme chemin d'accès
Loop 'boucle
End Sub

 

[zozo2502]

Bonjour Robert,
Merci pour ton retour, mais ca ne marche pas.
J'ai un message d'erreur sur la ligne Dim CS As worksbook 'déclare la variable CS (Classeur Source)

Merci de ton aide.

zozo2502

 

[Robert]

Re,

Oui pardon. Il y a un s en trop !... Corrige :

Dim CS As Workbook

 

[Robert]

Re,

je navet pas testé avant de t'envoyer. Erreur grave car il y avait un autre bug.
Code corrigé et testé :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CS As Workbook 'déclare la variable CD (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier excel F ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe des fichiers F
    Set CS = Workbooks.Open(CA & F) 'définit la classeur source CS en l'ouvrant
    Set OS = CS.Worksheets(1) 'définit l'onglet source OS
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    OS.Range("A1").CurrentRegion.Copy DEST 'copie les cellule de la plage A1 étendue aux cellules adjacentes
    CS.Close False 'ferme le classeur source sans l'enregistrer
    F = Dir 'définit le fichier excel suivant ayant ayant CA comme chemin d'accès
Loop 'boucle
End Sub

 

[zozo2502]

Merci Robert,
je fais le test et je te reviens.
Merci de ton aide.
zozo2502

 

[zozo2502]

@Robert ,
toujours un problème sur la ligne
F = Dir(CA & "*.xlsx") 'définit le premier fichier excel F ayant CA comme chemin d'accès

Merci tout de même de ton aide.

 

[Robert]

Re,

Où se trouve le fichier qui contient la macro et les autres fichiers ?

 

[Robert]

Le code est prévu pour que tous les fichiers soient dans le même dossier. Quelle est l'extension des 500 fichiers ?

 

[job75]

Bonjour Robert,

Avec 500 fichiers il ne faut pas les ouvrir, une méthode classique pour gagner du temps est d'utiliser des formules de liaison.

Mettez cette macro où vous voulez dans un classeur .xlsm que vous placerez dans le même dossier que les fichiers à copier :

Sub Consolider()
Dim chemin$, fichier$, feuille$, ad$, f$, lig&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter si nécessaire
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
feuille = "Sheet1" 'feuille à copier
ad = "A2:AY20" 'plage à copier
f = "='" & chemin & "[?]" & feuille & "'!" & ad 'formule adaptable"
lig = 2 '1ère ligne de restitution
Application.ScreenUpdating = False
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Rows("2:" & .Rows.Count).Delete 'RAZ, ligne de titres à renseigner
    While fichier <> ""
        If fichier <> ThisWorkbook.Name Then
            With .Range(ad).Offset(lig - 2)
                .FormulaArray = Replace(f, "?", fichier) 'formule de liaison matricielle
                .Value = .Value 'supprime la formule
                .Replace 0, "", xlWhole 'les cellules vides renvoient zéro
            End With
            lig = .UsedRange.Row + .UsedRange.Rows.Count 'nouvelle ligne de restitution
        End If
        fichier = Dir 'fichier suivant du dossier
    Wend
    .Columns.AutoFit 'ajustement largeurs
End With
End Sub

A+

 

[zozo2502]

Merci beaucoup @job75 la macro marche bien.


zozo2502

 

[job75]

Soyez gentil, il serait intéressant de donner les durées d'exécution sur 500 fichiers pour les 2 solutions que Robert et moi avons données.

 

[zozo2502]

Je vous remercie beaucoup tous les 2.
La solution de @Robert n'a pas marché je ne sais pour quelle raison... la votre a bien marché.
j'ai fait le test que sur 5 fichiers pour l'instant. je ferai avec les 500 fichiers et je vous dirai combien de temps la macro prend pour executer.

Merci encore.