Fusionner plusieurs classeurs

sr94

XLDnaute Occasionnel
Bonjour

J'avais déjà posté ici afin de pouvoir générer plusieurs fichiers à partir d'un seul.

Maintenant je cherche une solution pour mettre à jour mon fichier source et donc les refusionner.

J'ai trouvé les macros suivantes mais ça ne va pas

Pour récupérer tous les fichiers dans un seul classeur :

Code:
Sub ConvertirFichiersEnFeuilles()
On Error GoTo gesterreur
Dim VarListeFichiers As Variant, VarFichier As Variant, WkClasseur As Workbook, WkFinal As Workbook, WsFeuille As Worksheet
 
VarListeFichiers = Application.GetOpenFilename(filefilter:="Classeurs eXceL,*.xlsx", Title:="Choisissez les Classeurs à récupérer", MultiSelect:=True)
If VarType(VarListeFichiers) = vbBoolean Then MsgBox "Abandon !": Exit Sub  'pour identifier le bouton annuler
Set WkFinal = Workbooks.Add 'générer le classeur final
 
  For Ctr = 1 To UBound(VarListeFichiers)
    MsgBox VarListeFichiers(Ctr)
         
         Set WkClasseur = Workbooks.Open(Filename:=VarListeFichiers(Ctr))
         
         Set WsFeuille = WkClasseur.Worksheets(1)
            WsFeuille.Move before:=WkFinal.Worksheets(1)
        WkClasseur.Close savechanges:=False
   
  Next
 
'For Each VarFichier In VarListeFichiers
 
'Next VarFichier
 
Exit Sub
 
gesterreur:
'classeur vide
If Err.Number = -2147221080 Then
Resume Next
End If
 
End Sub

Mais mes fichiers sont créés dans un nouveau classeur et donc les macros doivent être recopiées ...

Bref ensuite pour fusionner les fichiers en un seul :

Code:
Sub RegroupeFeuilles() 'dans "Feuil1"
    Dim Lg&, Sh As Worksheet, f As Worksheet
            Set f = Sheets("Feuil1")
        f.Range("a2:AE" & f.[a65000].End(xlUp).Row).ClearContents    'efface Récap
       
        For Each Sh In Worksheets
            If Sh.Name <> f.Name And Sh.Name <> "bibi" Then         'feuilles à ne pas traiter
               Lg = Sh.Range("a" & Rows.Count).End(xlUp).Row
                Sh.Range("a2:AE" & Lg).Copy Destination:= _
                f.Range("a" & Rows.Count).End(xlUp)(2)
            End If
        Next
    End Sub

et enfin pour masquer les feuilles sauf la dernière que je viens de créer

Code:
Sub retirer()
    Dim ws As Worksheet
    For Each ws In Worksheets
        Application.DisplayAlerts = False
        If ws.Name <> "Feuil1" Then ws.Delete
    Next
    Application.DisplayAlerts = True
End Sub

Tout ça n'est pas très "propre" et surtout je ne peux pas lancer les macros automatiquement car après la première étape les informations sont dans un nouveau fichier.

Avez vous une idée ? (Vous l'aurez compris ... je n'y comprends rien en vba...)

Je dois absolument garder la mise en forme de mes fichiers et dans l'idéal garder ma première ligne (uniquement 1 fois sur la première ligne) et enfin si possible, que le résultat soit filtrer.

Le but étant au final de recopier ce tableau fusionné dans mon tableau source.

Tout mes fichiers ont la même structure puisque ils sont tous extraits d'un fichier source (ensuite mis à jour par chaque collaborateur et renvoyé à moi même pour la mise à jour globale).

Merci beaucoup
 
Dernière édition:

sr94

XLDnaute Occasionnel
Re : Fusionner plusieurs classeurs

Bonjour

J'ai trouvé le code suivant, ça marche mais il me recopie la première ligne d'en-têtes en haut de chaque classeur recopié, que peut-on modifier dans ce code pour ne garder la première ligne qu'une seule fois ?

J'aimerai aussi ne recopier les données qu'à partir de la colonne D et pas les 3 premières colonnes

Code:
Sub Compilation()
Dim Temp As String
Dim Ligne As Long
Temp = Dir(ActiveWorkbook.Path & "\*.xlsx")
Application.DisplayAlerts = False
Do While Temp <> ""
If Temp <> "Recap.xls" Then
Workbooks.Open ActiveWorkbook.Path & "\" & Temp
Workbooks(Temp).Sheets(1).Range("A1").CurrentRegion.Copy
Workbooks("Recap.xls").Sheets(1).Activate
Ligne = Sheets(1).Range("A65536").End(xlUp).Row + 1
Range("A" & CStr(Ligne)).Select
ActiveSheet.Paste
Workbooks(Temp).Close
End If
Temp = Dir
Loop
Range("A1").Select
Application.DisplayAlerts = True
End Sub

Merci beaucoup
Sandrine
 
Dernière édition:

sr94

XLDnaute Occasionnel
Re : Fusionner plusieurs classeurs

J'ai réussi à bricoler un code fonctionner, mais ça reste du bricolage, est ce qu'il est possible de le simplifier ? (ou de faire autrement)

Code:
Sub Compilation()
Dim Temp As String
Dim Ligne As Long
Temp = Dir(ActiveWorkbook.Path & "\*.xlsx")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
Do While Temp <> ""
If Temp <> "Recap.xls" Then
Workbooks.Open ActiveWorkbook.Path & "\" & Temp
Workbooks(Temp).Sheets(1).Range("E2").CurrentRegion.Copy
Workbooks("Recap.xls").Sheets(1).Activate
Ligne = Sheets(1).Range("A65536").End(xlUp).Row + 1
Range("A" & CStr(Ligne)).Select
ActiveSheet.Paste
Workbooks(Temp).Close
End If
Temp = Dir
Loop
Range("A1").Select
Application.DisplayAlerts = True

Range("A2:AE3143").Select
    Selection.AutoFilter
    Range("A2").Select
    ActiveWindow.SmallScroll Down:=-15
    Rows("1:1").RowHeight = 48
    
        ActiveSheet.Range("$A$2:$AE$3000").AutoFilter Field:=8, Criteria1:= _
        "Supplier"
    Rows("3:3000").Select
    Range("A13").Activate
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=-21
        ActiveSheet.Range("$A$2:$AE$3000").AutoFilter Field:=8
        
        ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("H3:H1984"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("E3:E1984"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("F3:F1984"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("G3:G1984"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
        
End Sub

Merci
 

Iznogood1

XLDnaute Impliqué
Re : Fusionner plusieurs classeurs

Une proposition qui
  • efface les données de ton fichier "Recap" en conservant la première ligne
  • puis consolide les données des autres fichiers en excluant la première ligne (prend les colonnes D à Z ; remplace "Z" par la colonne désirée dans la ligne wb.Worksheets(1).Range("D2:Z" & wb.Worksheets(1).Range("D2").CurrentRegion.Rows.Count).Copy)

Code:
 Option Explicit

Sub Compilation()
  Dim fileName As String
  Dim wb As Workbook
  
  ThisWorkbook.Worksheets(1).Range("A2:Z" & ThisWorkbook.Worksheets(1).Range("A2").CurrentRegion.Rows.Count).ClearContents
  fileName = Dir(ActiveWorkbook.Path & "\*.xlsx")
  
  Application.ScreenUpdating = False
  Do While fileName <> ""
    If fileName <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(ActiveWorkbook.Path & "\" & fileName)
      wb.Worksheets(1).Range("D2:Z" & wb.Worksheets(1).Range("D2").CurrentRegion.Rows.Count).Copy
      ThisWorkbook.Worksheets(1).Activate
      Range("A" & Worksheets(1).Range("A1").CurrentRegion.Rows.Count + 1).Select
      ActiveSheet.Paste
      wb.Close False
    End If
    fileName = Dir
  Loop
  Set wb = Nothing
  
  [A1].Select
  Application.ScreenUpdating = True
End Sub
 

sr94

XLDnaute Occasionnel
Re : Fusionner plusieurs classeurs

Merci pour ce code, malheureusement les lignes ne sont pas copiées, par contre ma première ligne est bien conservée mais en dessous il n'y a rien du coup. J'ai bien remplacé le Z par AE là où tu m'as dit.

Et j'ai également des erreurs en quoi le presse papier contient beaucoup d'informations etc ...

Merci
 

sr94

XLDnaute Occasionnel
Re : Fusionner plusieurs classeurs

Le tableau s'est bien actualisé la première fois correctement (mais j'avais quelques lignes vides sous l'en-tête) mais la 2e fois il n'y a pas des données qu'à partir de la 1989e ligne ! J'ai l'impression qu'il efface les données et copie les nouvelles en dessous (mes données actuelles font 1983 lignes)

Et toujours cette erreur de presse papiers.

Je n'arrive pas à envoyer le fichier il est trop gros apparemment

Merci beaucoup !
 
Dernière édition:

sr94

XLDnaute Occasionnel
Re : Fusionner plusieurs classeurs

J'ai modifié le début de la macro comme suit et ça marche, merci beaucoup !

Code:
Sub Compilation()
  Dim fileName As String
  Dim wb As Workbook
  
  Application.DisplayAlerts = False
  
  ThisWorkbook.Worksheets(1).Range("A2:Z" & ThisWorkbook.Worksheets(1).Range("A2").CurrentRegion.Rows.Count).EntireRow.Delete
  fileName = Dir(ActiveWorkbook.Path & "\*.xlsx")
 

Discussions similaires

Réponses
3
Affichages
91

Membres actuellement en ligne

Statistiques des forums

Discussions
312 084
Messages
2 085 192
Membres
102 809
dernier inscrit
Sandrine83