Réunir dans 1 classeur les infos de plusieurs classeur par macro

L

LPandre

XLDnaute Impliqué
Bonjour,
dans un répertoire C:\Monrep\ j'ai plusieurs fichiers du type 650.xls, 780.xls, etc.xls

le nombre de fichiers peut varier d'un jour à l'autre.

Dans chacun des fichiers j'ai sur l'onglet Feuille1 des informations : Mat, Nom, Total1, total1, etc.
Le nombre de colonne est le même pour tous les fichiers,
Le nombre de lignes est différents selon les fichiers.

Comment par macro, est il possible de réunir ( copier/coller ?) dans 1 autre fichier ( synthes.xls par exemple) et sur 1 seul onglet de ce fichier TOUTES les infos de TOUS les autres fichiers. Les infos s'écrivant les unes en dessous des autres au fur et à mesure dans le fichier synthese.

Difficulté supplémentaire : le premier copier/coller va mettre les tires des colonnes dans le fichier de synthese, ensuite ces titres ne sont plus nécessaires. Mais s'il ne reste que ça, je supprimerai les lignes de titres en rab à la main

Par avance merci.
 
Trier par date Trier par votes
L

LPandre

XLDnaute Impliqué
Re : Réunir dans 1 classeur les infos de plusieurs classeur par macro

Sauf erreur la macro que tu proposes, consiste à réunir dans un fichier des onglets d'autres fichiers. Je n'ai pas réussi à la faire tourner sur mon poste. Mais mon souhait est différent : copier toutes les infos de l'onglet Feuil1 de chacun des autres fichiers , dans un seul et même onglet du fichier de récap/synthese.
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Réunir dans 1 classeur les infos de plusieurs classeur par macro

Voilà ,

Chemin et colonnes à adapter si nécessaire,
car sans fichier et sans précision pas possible de faire mieux

Attention , cette macro est à mettre dans un module standard dans un classeur contenant une feuille synthese


Code: 
Sub FusionFichiers()

 Dim Classeur As String
 Dim Chemin As String
 Dim Onglet As Worksheet
 Dim LigneFin As Long, LigneFinACopier As Long
 'Exemple : Chemin à adapter
 Chemin = "C:\Test_Fusion_Classeurs\"
 'Si uniquement des fichiers xls ou xslx , modifier l'extension en conséquence
 Classeur = Dir(Chemin & "*.xls")
 If Classeur = "" Then MsgBox " Le répertoire " & Chemin & " est vide ou inexistant": Exit Sub
 Do
 If Classeur <> "" Then
 Application.EnableEvents = False
 Workbooks.Open Chemin & Classeur
 For Each Onglet In Workbooks(Classeur).Worksheets
 'Ne traite que les onglets dont le nom ne commence pas par Feuil
      If Left(Onglet.Name, 5) = "Feuille1" Then
     
       'Ajout de la création de l'onglet
       LigneFin = ThisWorkbook.Sheets("Synthese").Range("A" & Rows.Count).End(xlUp).Row
       LigneFinACopier = Onglet.Range("A" & Rows.Count).End(xlUp).Row
        Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).Range("A" & LigneFin + 1)
      End If
 Next
 Workbooks(Classeur).Close False
 Application.EnableEvents = True
 End If
 Classeur = Dir
 Loop Until Classeur = ""
 End Sub
 
Vote positif 0 Vote négatif
Jam

Jam

XLDnaute Accro
Re : Réunir dans 1 classeur les infos de plusieurs classeur par macro

Salut LPandre, camarchepas,

Ci-dessous ma petite proposition:
Le principe: on ouvre le fichier "Synthèse" et on copie dans un onglet toutes les données des fichiers d'un répertoire (déterminé dans la cellule nommée sPath). On recopie ensuite les infos des cellules (ici 6 cellules, à adapter à ton problème). Pas de ligne de titre gérée non plus.
Petit truc en plus dans cet exemple, il parcours les onglets du fichier source à la recherche d'un onglet spécifique. A retirer si cela ne te sers pas.

Bon courage

VB: 
Option Explicit

'========================
'= Procédure principale =
'========================
Sub Main()
    '# Déclaration des variables de la procédure
    Dim oFso        As Object
    Dim oFile       As Object
    Dim oDirectory  As Object
    Dim wkbDEST     As Workbook
    Dim wkbSOURCE      As Workbook
    Dim wks         As Worksheet
    Dim i           As Long   'Compteur pour décalage des lignes
    
    '# Création des objets de scripting
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Set oDirectory = oFso.getfolder(Range("sPath"))
    
    '# Affectation de la variable wkbDEST au classeur accueillant les données
    Set wkbDEST = ThisWorkbook
    
    '# On active la gestion d'erreur
    On Error GoTo GestionErreur
    
    '# On vérifie qu'il y a bien des fichiers dans le répertoire
    If Not (oDirectory.Files.Count > 0) Then
        MsgBox "Le répertoire sélectionné ne contient aucun fichier !", vbCritical + vbOKOnly, "Erreur répertoire"
        Exit Sub
    End If
    
    '# Effacement de la plage de données
    wksDatabase.Range("A1").CurrentRegion.Clear
    
    '# Désactivation de certains paramètres pour accélerer le traitement
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    '# On parcours tous les fichiers du répertoire
    For Each oFile In oDirectory.Files
        '# Si le fichier est un fichier Excel on l'ouvre. Attention il n'y a aucune
        '# vérification
        If Right(oFile.Name, 4) = ".xls" Then
            Workbooks.Open Range("sPath") & "\" & oFile.Name
            Set wkbSOURCE = ActiveWorkbook
            '# On parcours les onglets du fichier.
            '# S'il s'agit d'un nombre c'est un site et on copie.
            For Each wks In wkbSOURCE.Worksheets
                '# Si le nom fait 3 caractère alors il s'agit d'une source
                If Len(wks.Name) = 3 Then
                    i = i + 1
                    With wksDatabase
                        .Cells(i, 1) = wks.Name
                        .Cells(i, 2) = wks.Range("D13")
                        .Cells(i, 3) = wks.Range("E13")
                        .Cells(i, 4) = wks.Range("D22")
                        .Cells(i, 5) = wks.Range("E22")
                        .Cells(i, 6) = wks.Range("G24")
                    End With
                End If
            Next
        End If
    Next
    
GestionErreur:
    '# On ferme les objets créés
    Set oFso = Nothing
    Set oDirectory = Nothing
    
    '# Rétablissement des paramètres Excel
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .StatusBar = False
    End With
    
    MsgBox "Les données des fichiers ont été importées avec succès.", vbOKOnly + vbInformation, "Fin Traitement"


End Sub
 
Vote positif 0 Vote négatif
L

LPandre

XLDnaute Impliqué
Re : Réunir dans 1 classeur les infos de plusieurs classeur par macro

Bon , j'ai commencé par tester le code le plus simple à mes yeux.
J'ai donc testé et modifié un tout petit peu le code de "çamarchepas" et c'est OK à 90%
le code résultant :

Sub FusionFichiers()
Dim Classeur As String
Dim Chemin As String
Dim Onglet As Worksheet
Dim LigneFin As Long, LigneFinACopier As Long
'Exemple : Chemin à adapter
Chemin = "C:\DRH\"
'Si uniquement des fichiers xls ou xslx , modifier l'extension en conséquence
Classeur = Dir(Chemin & "*.xls")
If Classeur = "" Then MsgBox " Le répertoire " & Chemin & " est vide ou inexistant": Exit Sub
Do
If Classeur <> "" Then
Application.EnableEvents = False
Workbooks.Open Chemin & Classeur
For Each Onglet In Workbooks(Classeur).Worksheets
'Ne traite que les onglets dont le nom ne commence pas par Feuil
If Left(Onglet.Name, 5) <> "Feuil" Then
'Ajout de la création de l'onglet
LigneFin = ThisWorkbook.Sheets("Synthese").Range("A" & Rows.Count).End(xlUp).Row
LigneFinACopier = Onglet.Range("A" & Rows.Count).End(xlUp).Row
Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).Range("A" & LigneFin + 1)
End If
Next
Workbooks(Classeur).Close False
Application.EnableEvents = True
End If
Classeur = Dir
Loop Until Classeur = ""
End Sub

Les modifs portent sur le chemin du répertoire ( normal), et j'ai remplacé If left... ="Feuille1" then par <>"Feuil"...

ça fonctionne plutôt bien, sauf qu'il faut que les onglets contenant les données des fichiers sources s'appellent "synthese" pour qu'il rapatrie ces données dans le fichier de récap (dont l'onglet de récap s'appelle lui aussi Synthese).
Or les onglets "sources" s'appellent 100, 212, ...,664, jusqu'à 9999 ( sans aucune logique de progression, il s'agit de n° de services)

Peux tu adapté le code pour d'il prenne en compte cette particularité, ou dois je faire en sorte que les onglets sources portent le nom "Shynthese" ?

De nouveau merci.
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Réunir dans 1 classeur les infos de plusieurs classeur par macro

Oups ,
un mauvais copier coller éducatif on va dire , lol

la ligne :
Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).Rang e("A" & LigneFin + 1)

est en fait :

Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets("Synthese").Range("A" & LigneFin + 1)

Bon petite explication ,
L'on copie la zone A1:H derniereligne de l'onglet en cours d'un des classeurs dans l'onglet synthese de ce classeur

ATTENTION : La colonne A doit être toujours renseignée , c'est elle qui indique le nombre de ligne à copier , sinon , il faut modifier dans LigneFinACopier la colonne

Code: 
Sub FusionFichiers()
 Dim Classeur As String
 Dim Chemin As String
 Dim Onglet As Worksheet
 Dim LigneFin As Long, LigneFinACopier As Long
 'Exemple : Chemin à adapter
 Chemin = "C:\DRH\"
 'Si uniquement des fichiers xls ou xslx , modifier l'extension en conséquence
 Classeur = Dir(Chemin & "*.xls")
 If Classeur = "" Then MsgBox " Le répertoire " & Chemin & " est vide ou inexistant": Exit Sub
 Do
 If Classeur <> "" Then
 Application.EnableEvents = False
 Workbooks.Open Chemin & Classeur
 For Each Onglet In Workbooks(Classeur).Worksheets
 'Ne traite que les onglets dont le nom ne commence pas par Feuil
 If Left(Onglet.Name, 5) <> "Feuil" Then
 'Ajout de la création de l'onglet
 LigneFin = ThisWorkbook.Sheets("Synthese").Range("A" & Rows.Count).End(xlUp).Row
 LigneFinACopier = Onglet.Range("A" & Rows.Count).End(xlUp).Row
 Workbooks(Classeur).Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets("Synthese").Range("A" & LigneFin + 1)
 End If
 Next
 Workbooks(Classeur).Close False
 Application.EnableEvents = True
 End If
 Classeur = Dir
 Loop Until Classeur = ""
 End Sub
 
Vote positif 0 Vote négatif
L

LPandre

XLDnaute Impliqué
Re : Réunir dans 1 classeur les infos de plusieurs classeur par macro

J'ai juste modifié
Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets(Onglet.Name).... etc

par
Onglet.Range("A1:H" & LigneFinACopier).Copy Destination:=ThisWorkbook.Sheets("Synthese")...etc,

comme tu l'indiquais juste plus haut et ça fonctionne impec.

Je rajouterai un peu de code pour gérer les titres, mais ça c'est facile.


@+
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
XL 2019 Power query - Réunir le contenu de plusieurs fichiers xls dans un seul
Réponses
10
Affichages
1 K
Bernard_XLD
Bernard_XLD
T
  • Question
XL 2016 Récupérer le contenu de cellule par VBA
2 3
Réponses
37
Affichages
1 K
telemarrk
T
V
  • Question
Microsoft 365 Resume de plusieurs fichier
Réponses
2
Affichages
162
Cousinhub
Cousinhub
N
  • Résolu(e)
XL 2019 Remonter de formules entre Classeur
Réponses
2
Affichages
259
naelis
N
D
  • Question
Microsoft 365 Infos dans plusieurs onglets à réorganiser dans plusieurs onglets
Réponses
7
Affichages
326
fanfan38
fanfan38
B
  • Question
XL 2019 Création d'une base de données à partir de plusieurs fichiers Excel
Réponses
5
Affichages
915
battijo
B
L
  • Question
Microsoft 365 Macro choisir onglet à exporter dans un nouveau classeur
Réponses
5
Affichages
370
l.et.lilou
L
Darkopsix
  • Résolu(e)
XL 2021 Récupérer des données de fichiers dons les noms sont renseignés dans des cellules
Réponses
2
Affichages
435
Darkopsix
Darkopsix
A
  • Résolu(e)
Microsoft 365 cumuler des valeurs de cellules dont l'emplacement peut varier dans des tableaux
Réponses
4
Affichages
248
auloin
A
C
  • Question
XL 2021 Excel facturation avec BD clients (modèle utilisable joint) - liste déroulante =INDIRECT sur classeur séparé
Réponses
12
Affichages
364
Calizarine
C

Membres actuellement en ligne

16 membres et 106 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 332
Messages
2 087 361
Membres
103 530
dernier inscrit
Chess01