Fusion de plusieurs fichiers en un seul

[lilijolie]

Bonjour à tous,

Il se trouve que j'ai besoin de fusionner des fichiers Excel.

Il s'agit de fichiers identiques mais certains mis à jour par ma collègue, d'autres par moi-même (fichiers en PJ A... + B... + C...). Ils ne sont donc pas exactement sous le même emplacement. Chaque fichier est constitué de plusieurs feuilles mais une seule m'intéresse (DB). L'onglet à rapatrier depuis chacun de ces fichiers se nomme exactement pareil (DB) et le format de l'onglet est exactement le même. Le tout devant être rapatrié dans le fichier Global (PJ).

J'ai vu qu'il y avait beaucoup de posts à ce sujet. J'ai tenté d'implémenter les codes trouvés mais cela ne semble pas fonctionner (je devrais plutôt dire "je n'ai fait QUE copier le code et ne suis pas capable de l'adapter à mon cas car je ne connais pas grand-chose en ce qui concerne les macros).

Bonne journée et bon weekend à tous!
Lilijolie

 

[Gareth]

Re : Fusion de plusieurs fichiers en un seul

Bonsoir,

Ci-joint une macro à tester.
Tous les fichiers doivent etre dans le meme dossier pour le test

 

[camarchepas]

Re : Fusion de plusieurs fichiers en un seul

Bonjour LiliJolie, Gareth,

Petite amélio du code démonstratif de M. Gareth

Bon , la déclaration des variables évite bien des ennuis , surtout lorsqu'il y en à beaucoup.

Paramétrage du nom de l'onglet en variable, si besoin de le changer , juste une ligne à modifier

Attention à l'utilisation de .path , car si le fichier n'est pas sauvegardé , boum chaine vide.

Ajout d'un filtre sur l’extension des fichiers lu par Dir pour ne voir que les extensions Xls et combinés

Désactivation du rafraiche écran pour améliorer temps d’exécution et aspect traitement

Ajout de l’existence de l'onglet en condition de traitement du classeur.

En principe , sauf format bizarroïde de l'onglet à recopier, ce code qui devient un travail d'équipe devrait te donner toute satisfaction.

Option Explicit

Sub Test()
'Déclaration des variables
Dim Chemin As String, Fichier As String
Dim Onglet As Worksheet
Dim OngletCible As String
Dim OngletOK As Boolean

OngletCible = "DB"
ThisWorkbook.Sheets(OngletCible).Cells.Clear
Chemin = ThisWorkbook.Path

'Si classeur non sauvegardé alors pas de chemin
If Chemin <> "" Then
 'Filtre uniquement sur les fichiers Excel
 Fichier = Dir(Chemin & "\*.*xls*")
 'Améliore vitesse et aspect du traitement en désactivant le rafraiche
 Application.ScreenUpdating = False
 Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=Chemin & "\" & Fichier
        
        'Test si onglet existe
         OngletOK = False
         For Each Onglet In Workbooks(Fichier).Sheets
          If Onglet.Name = OngletCible Then OngletOK = True: Exit For
         Next
        
        If OngletOK Then
         Workbooks(Fichier).Sheets(OngletCible).Range("A1").CurrentRegion.Resize(1).Copy ThisWorkbook.Sheets(OngletCible).Range("A1")
         Workbooks(Fichier).Sheets(OngletCible).Range("A1").CurrentRegion.Offset(1, 0).Copy ThisWorkbook.Sheets(OngletCible).Range("A1").Offset(ThisWorkbook.Sheets(OngletCible).Range("A1").CurrentRegion.Rows.Count, 0)
        End If
        
        Workbooks(Fichier).Close False

    End If
    Fichier = Dir
 Loop

' Réactive Le rafraiche écran
 Application.ScreenUpdating = True
End If
End Sub

 

[lilijolie]

Re : Fusion de plusieurs fichiers en un seul

Bonjour,

Et merci beaucoup à vous trois (Je pense que PMO2 suivait également ce message). Je vais tester la macro aujourd'hui et vous tiendrai informés.

Très bonne journée (malgré le temps!) à vous.
Cordialement,
Lilijolie

 

[lilijolie]

Re : Fusion de plusieurs fichiers en un seul

Bonjour,

J'ai implémenté ce weekend le code que vous m'avez fourni et je me heurte à deux tous petits problèmes :
- j'ai des noms de plages de cellules dans mes fichiers sources et un message aparrait donc lors de l'exécution de la macro
- certaines cellules restent liées à des fichiers externes, serait-il possibles de couper ces liens ? En revanche, les formules basiques (somme, moyenne,...) qu'il y a dans le fichier initial restent et c'est parfait ! => couper les liens mais garder les formules basiques
- la macro importe également l'en-tête des colonnes de chacun des fichiers importés, en-tête que je ne voudrais avoir qu'une seule fois, en en-tête...

Auriez-vous des suggestions ?

Sinon, tout le reste marche très très bien, merci beaucoup ! Vous m'avez permis de gagner une journée de travail !

Bonne journée,
Lilijolie

 

[camarchepas]

Re : Fusion de plusieurs fichiers en un seul

Bonsoir ,

Pas eu de dispo , je me rattrape ce soir ,
j'espère que vous êtes toujours sur ce projet.

D'après le message d'erreur que tu as joint , le nom du champ nommé est Budget, si tel n'est pas le cas , il faudrait mettre le bon nom dans le code , voir supprimer tous les champs nommés.

J'ai également pris en compte la non copie des entêtes.

Option Explicit

Sub HC_Global()
'Déclaration des variables
Dim Path As String, File As String
Dim Worksheet As Worksheet
Dim Target_Worksheet As String
Dim LigneRef As Long
Dim OK_Worksheet As Boolean, Début As Boolean
Dim Nom As Name

Target_Worksheet = "DB"
ThisWorkbook.Sheets(Target_Worksheet).Cells.Clear
Path = ThisWorkbook.Path
'Monte le flag de Start
Début = True

'If unsaved file, then no path => always save the file before executing the macro
If Path <> "" Then
 'Filter only on Excel files
 File = Dir(Path & "\*.*xls*")
 'Only "esthetic" : improves speed and processing appearance (deactivating sreen update)
 Application.ScreenUpdating = False
 Do While File <> ""
    If File <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=Path & "\" & File
        
        'Test if worksheet exists
         OK_Worksheet = False
         For Each Worksheet In Workbooks(File).Sheets
          If Worksheet.Name = Target_Worksheet Then OK_Worksheet = True: Exit For
         Next
       'Si feuille ok alors copie du contenu du fichier X vers la base de données
        If OK_Worksheet Then
        'Décalage de l'entête si pas premier fichier copié
         LigneRef = IIf(Début, 1, 2)
         Workbooks(File).Sheets(Target_Worksheet).Range("A" & LigneRef).CurrentRegion.Offset(1, 0).Copy ThisWorkbook.Sheets(Target_Worksheet).Range("A1").Offset(ThisWorkbook.Sheets(Target_Worksheet).Range("A1").CurrentRegion.Rows.Count, 0)

        'Si dans ce classeur un champ nommé Budget alors suppression
         For Each Nom In ThisWorkbook.Names
          If Nom.Name = "Budget" Then Nom.Delete
         Next
        'Supprime le flag de start
         Début = False
        End If
        
        Workbooks(File).Close False

    End If
    File = Dir
 Loop

' Re-activates screen update
 Application.ScreenUpdating = True
End If
End Sub

 

[lilijolie]

Re : Fusion de plusieurs fichiers en un seul

Bonjour Nono et merci pour ta réponse.

Je travaille toujours sur ce fichier. Ta solution est donc la bien venue ! Ce code fonctionne très bien dans le fichier d'exemple. Pourtant, quand je l'implémente sur mon fichier de travail, les lignes d'en-tête sont toujours copiées trois fois (car trois fichiers importés)... Je ne comprends pas parce que j'ai exactement la meme disposition en termes de lignes et colonnes...
Je continue de creuser !

Merci encore et bonne journée
Lilijolie

P.S. : désolée pour le retard de ma réponse mais je n'avais pas eu la notification de message.

 

[kjin]

Re : Fusion de plusieurs fichiers en un seul

Bonjour,

Il s'agit de fichiers identiques mais certains mis à jour par ma collègue, d'autres par moi-même (fichiers en PJ A... + B... + C...). Ils ne sont donc pas exactement sous le même emplacement

Tu ne précises rien à ce sujet et je m'étonne....
Je suis parti du principe que les fichiers sont connus et que leur chemin d'accès est indiqué en feuil1

Sub zzzzzzzzzz()
Dim i#, pfile$
Dim wb As Workbook, ws As Worksheet
Dim rng1 As Range, rng2 As Range, tablo
For i = 1 To 3
    Set rng1 = ActiveSheet.Range("A65000").End(xlUp).Offset(1)
    pfile = ActiveWorkbook.Path & "\" & Feuil1.Cells(i, 1) 'à adapter
    If Dir(pfile) <> "" Then
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(pfile)
        With wb
            On Error Resume Next
            Set ws = .Sheets("DB")
            On Error GoTo 0
            If Not ws Is Nothing Then
                Set rng2 = ws.Range("A1").CurrentRegion
                With rng2
                    tablo = .Offset(1).Resize(.Rows.Count - 1)
                End With
            End If
            rng1.Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
        End With
        wb.Close False
    End If
Next
End Sub

A+
kjin