Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

zozo2502

XLDnaute Nouveau
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

XLDnaute Barbatruc
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

XLDnaute Nouveau
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

XLDnaute Barbatruc
Repose en paix
Bonjour Zozo, bonjour le forum,

En gros ça donne ça :

Code:
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
 

Robert

XLDnaute Barbatruc
Repose en paix
Re,

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

VB:
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
 

job75

XLDnaute Barbatruc
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 :
VB:
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

XLDnaute Nouveau
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.
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…