Fusion de classeurs excels

[visirilix]

Bonsoir,
voici mon problème :
Je dispose de 5 classeurs fermés référencés comme suit:
op1_template_amr_1
op1_template_amr_2
op1_template_amr_3
op1_template_amr_4
op1_template_amr_5

Chaque classeur contient une feuille nommée Histogram Formatted Data.
Je souhaite récupérer de manière automatique les plages de données M36:BA119 de chaque classeur pour les mettre dans un nouveau classeur RECAP les unes après les autres.
Cela donnerait le résultat suivant :
Sur RECAP :
- une seule feuille contenant les plages de données concaténées.

Note : Tous les classeurs XL sont fermés.
Quelqu'un peut il m'aider à écrire cette macro.
Je suis débutant en terme de Macro
Merci pour votre aide
Cordialement

 

[BERRACHED said]

Re : Fusion de classeurs excels

Salut,visirilix

voila les codes que tu peux les adapter a votre cas :

'récupère dans une série de classeurs fermés (dans le même répertoire)
'les valeurs d'une plage et les écrit dans la feuille active

Sub LoopThruFiles()
Dim place As String
Dim FilesArray() As String, FileCounter As Integer
Dim FName As String, LoopCounter As Integer
    
  FName = Dir("c:\*.xls")
  Do While Len(FName) > 0
    FileCounter = FileCounter + 1
    ReDim Preserve FilesArray(1 To FileCounter)
    FilesArray(FileCounter) = FName
    FName = Dir()
  Loop
  If FileCounter > 0 Then
    Application.ScreenUpdating = False
    For LoopCounter = 1 To FileCounter

    x = LoopCounter
    'calcul de la plage de destination
    place = Range(Cells((((x - 1) * 10) + 2), 1), Cells(((x * 10)), 3)).Address
    GetValues "c:", FilesArray(LoopCounter), "Blad1", "a1:c10", place
    Next
    Application.ScreenUpdating = True
  End If
End Sub

Sub GetValues(fPath As String, FName As String, sName, _
              cellRange As String, place As String)
'recopie une plage des valeurs externes dans une plage de
'la feuille active sous forme d'une formule matricielle
  With ActiveSheet.Range(place)
    .FormulaArray = "='" & fPath & "\[" & FName & "]" & sName & "'!" & cellRange
    .Value = .Value
  End With
End Sub

Cordialement

 

[ROGER2327]

Re : Fusion de classeurs excels

Bonjour à tous

Une solution paramétrable : les fichiers ne sont pas nécessairement dans le même dossier, les noms peuvent être modifiés, le nombre de fichiers à traiter peut changer.
Le contrôle de l'existence des fichiers et des feuilles à traiter est effectué.
Vous pouvez tester, visirilix. Si cela peut aider, tant mieux...

 

[visirilix]

Re : Fusion de classeurs excels

Merci pour ton feedback je vais l'essayer et je te répond
Cordialement

 

[visirilix]

Re : Fusion de classeurs excels

Merci Roger pour ton CS.
c'est exactement ce qu'il me faut c'est comme si tu lis mes pensées..j'ai un input qui est variable pour le récap donc ton code paramétrable fait l'affaire pour moi. Mais il me reste un tout petit souci à régler c'est que sur le RECAP j'ai besoin de garder les formats des colonnes identiques aux fichiers de départs. j'ai besoin surtout de garder le format pourcentage vu que je plote des graphes en CDF après. je peu changer les formats manuellement après le merging mais y'a t'il un moyen de les forcer sur le Code source ou autre?.?
Merci

 

[ROGER2327]

Re : Fusion de classeurs excels

Bonjour !

A visirilix :

Tant mieux si cette procédure peut vous être utile. Mais je ne lis pas dans vos pensées : nous sommes confrontés aux mêmes problèmes, donc, avec l'expérience, nous anticipons les demandes.​

(...) ..j'ai un input qui est variable pour le récap donc ton code paramétrable fait l'affaire pour moi. Mais il me reste un tout petit souci à régler c'est que sur le RECAP j'ai besoin de garder les formats des colonnes identiques aux fichiers de départs. j'ai besoin surtout de garder le format pourcentage vu que je plote des graphes en CDF après. je peu changer les formats manuellement après le merging mais y'a t'il un moyen de les forcer sur le Code source ou autre?.?
Merci

Pour le reste, si je comprends bien, vous voudriez importer le format avec le contenu de vos sources de données dans différents classeurs, éventuellement situés dans des dossiers distincts ; notamment, le format "pourcentage", en vue de l'utiliser pour légender des représentations graphiques (je ne comprens pas "en CDF").​

Vous pouvez effectivement définir les formats dans la feuille RECAP de votre classeur de fusion. Il me semble que ces formats seront conservés lors des mises à jour successives, sans que vous ayez à les redéfinir. L'avantage de cette façon de faire est que vos données collectées auront un aspect uniforme, même si les fichiers-sources ne sont pas tous formatés identiquement.​

Toutefois, si vous préférez copier vos sources à l'identique, vous pouvez utiliser le code suivant :​

Option Explicit

Sub Collecte_op_template_amr()
'
' Procédure enregistrée le 14 Brumaire CCXVII (4/11/2008) par ROGER2327
' Procédure modifiée le 15 Brumaire CCXVII (5/11/2008) par ROGER2327
'

'
Dim i As Long, j As Long, tf As Boolean
Dim param_des_fichiers, chemin As String, fichier As String, n As Long, s, cf As String
    Application.ScreenUpdating = False

' Sélection des paramètres sur la feuille "PARAM".
    param_des_fichiers = ThisWorkbook.Sheets("PARAM").Cells(1, 1).CurrentRegion

' Vérification de l'existence et comptage des fichiers à traiter.
    If UBound(param_des_fichiers, 1) > 1 Then
        For i = 2 To UBound(param_des_fichiers, 1)
            tf = False
            chemin = param_des_fichiers(i, 1)
            If Right$(chemin, 1) <> "\" Then chemin = chemin & "\"
            param_des_fichiers(i, 1) = chemin
            fichier = param_des_fichiers(i, 2)
            cf = Dir(chemin)
            Do While cf <> ""
                If cf = fichier Then tf = True: Exit Do
                cf = Dir
            Loop
            If tf Then
                n = n + 1
            Else
                param_des_fichiers(i, 1) = Empty
                MsgBox "Il n'existe pas de chemin " & vbLf & chemin & fichier
            End If
        Next i
    Else
        MsgBox "Il n'y a aucun dossier à traiter."
    End If

' S'il existe au moins un chemin requis, lecture du bloc "M36:BA119" de ce
' chemin et écriture du bloc dans la feuille "RECAP" à partir de la ligne 2.
' Les données des éventuels fichiers suivants sont écrites aux lignes 85, 169, ...
    If n > 0 Then
        n = 0
        For i = 2 To UBound(param_des_fichiers, 1)
            tf = False
            If Not IsEmpty(param_des_fichiers(i, 1)) Then
                Workbooks.Open Filename:=param_des_fichiers(i, 1) & param_des_fichiers(i, 2)
                With ActiveWorkbook
                    For j = 1 To .Sheets.Count
                        If Sheets(j).Name = param_des_fichiers(i, 3) Then
                            tf = True
                            .Sheets(param_des_fichiers(i, 3)).Range("M36:BA119").Copy
                        End If
                    Next j
                    If tf Then
                        With ThisWorkbook.Sheets("RECAP")
                            .Activate
                            .Range(.Cells(84 * n + 2, 1), .Cells(84 * (n + 1) + 1, 41)).Select
                            ActiveSheet.Paste
                            Application.CutCopyMode = False
                        End With
                        n = n + 1
                    Else
                        MsgBox "Il n'y a pas de feuille """ & param_des_fichiers(i, 3) & """ dans le classeur """ & param_des_fichiers(i, 2) & """."
                    End If
                    .Close
                End With
            End If
        Next i
    End If
    ThisWorkbook.Sheets("RECAP").Activate
    Application.ScreenUpdating = True
End Sub

En espérant que cela réponde à vos souhaits...​

ROGER2327

 

[waine_99]

Re : Fusion de classeurs excels

Bonjour,

Cette fonction est très pratique. J'ai besoin d'ajouter une fonctionnalité: recopier pour chaque fichier toutes les lignes de la colonne A tant que celle-ci n'est pas vide. C'est à dire ne pas s'arreter 119.

J'ai bien trouvé une fonction qui permet de calculer le nombre cellule non vide, mais je n'arrive pas à l'utiliser:

Nlignes = Application.WorksheetFunction.CountA(Range("$A:$A"))
MsgBox Nlignes
Wbk_cible.Activate

Merci par avance de votre aide!

 

[ROGER2327]

Re : Fusion de classeurs excels

Bonsoir waine_99.

Sub Collecte()
'
' Procédure enregistrée le 14 Brumaire CCXVII (4/11/2008) par ROGER2327
' Procédure modifiée le 17 Floréal CCXXII (6/5/2014) par ROGER2327
'

'
Dim i&, j&, tf1 As Boolean, tf2 As Boolean
Dim param_des_fichiers, chemin$, fichier$, feuille$, msg$, cf$, n&, u
  Application.ScreenUpdating = False

  param_des_fichiers = ThisWorkbook.Sheets("PARAM").[A1].CurrentRegion.Value

  If UBound(param_des_fichiers, 1) > 1 Then
    For i = 2 To UBound(param_des_fichiers, 1)
      tf1 = True
      chemin = param_des_fichiers(i, 1)
      If Right$(chemin, 1) <> "\" Then chemin = chemin & "\"
      fichier = param_des_fichiers(i, 2)
      feuille = param_des_fichiers(i, 3)
      cf = Dir(chemin)
      Do While cf <> ""
        u = Empty
        If cf = fichier Then
          tf1 = False
          Workbooks.Open Filename:=chemin & fichier
          With ActiveWorkbook
            For j = .Worksheets.Count To 1 Step -1
              If .Worksheets(j).Name = feuille Then
                With Worksheets(j).[A1]
                  u = .Parent.Range(.Cells, IIf(IsEmpty(.Cells) Or IsEmpty(.Cells.Offset(1)), .Cells, .End(xlDown))).Value
                End With
                Exit For
              End If
            Next j
            .Close
          End With
          If j Then
            tf2 = False
            With ThisWorkbook.Sheets("RECAP").[A2].Offset(n)
              Select Case VarType(u)
              Case Is < vbArray:
                If IsEmpty(u) Then tf2 = True Else .Value = u: n = n + 1
              Case Else
                If IsEmpty(u(1, 1)) Then tf2 = True Else .Resize(UBound(u)).Value = u: n = n + UBound(u)
              End Select
            End With
            If tf2 Then msg = msg & vbLf & "Il n'y a pas de données dans la feuille """ & feuille & """ du classeur """ & fichier & """."
          Else
            msg = msg & vbLf & "Il n'y a pas de feuille """ & feuille & """ dans le classeur """ & fichier & """."
          End If
        End If
        cf = Dir
      Loop
      If tf1 Then msg = msg & vbLf & "Il n'existe pas de chemin " & vbLf & chemin & fichier
    Next i
  Else
    msg = msg & vbLf & "Il n'y a aucun dossier à traiter."
  End If
  If msg <> "" Then MsgBox msg

  ThisWorkbook.Sheets("RECAP").Activate
  Application.ScreenUpdating = True
End Sub

à placer dans un module du classeur REGROUPEMENT du message #3.​

ℝOGER2327
#7321

Mardi 17 Palotin 141 (Saint Macrotatoure, caudataire - fête Suprême Quarte)
17 Floréal An CCXXII, 9,9510h - pimprenelle
2014-W19-2T23:52:56Z

 

[waine_99]

Re : Fusion de classeurs excels

Merci Roger2327!

Est-il possible de préciser dans la feuille "PARAM", par Fichier, les colonnes que l'on souhaite copier?
Cf exemple dans le fichier joint.

 

[ROGER2327]

Re : Fusion de classeurs excels

Re...

Je me doutais un peu que le problème posé n'était pas le véritable problème à résoudre...
Que de perte de temps ! Un essai tout de même, car j'aime bien m'amuser :​

Sub Collecte()
'
' Procédure enregistrée le 14 Brumaire CCXVII (4/11/2008) par ROGER2327
' Procédure modifiée le 17 Floréal CCXXII (6/5/2014) par ROGER2327
' Procédure modifiée le 18 Floréal CCXXII (7/5/2014) par ROGER2327
'

'
Dim i&, j&, k&, tf As Boolean
Dim param_des_fichiers, chemin$, fichier$, feuille$, msg$, cf$, n&, h&, u, v()
  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
  On Error GoTo Ea

  ThisWorkbook.Sheets("RECAP").[A1].CurrentRegion.Offset(1).ClearContents
  param_des_fichiers = ThisWorkbook.Sheets("PARAM").[A1].CurrentRegion.Value
  ReDim v(4 To UBound(param_des_fichiers, 2))

  If UBound(param_des_fichiers, 1) > 1 Then
    For i = 2 To UBound(param_des_fichiers, 1)
    If Not IsEmpty(param_des_fichiers(i, 4)) Then
      tf = True
      chemin = param_des_fichiers(i, 1)
      If Right$(chemin, 1) <> "\" Then chemin = chemin & "\"
      fichier = param_des_fichiers(i, 2)
      feuille = param_des_fichiers(i, 3)
      cf = Dir(chemin)
      Do While cf <> ""
        u = Empty
        If cf = fichier Then
          tf = False
          Workbooks.Open Filename:=chemin & fichier
          With ActiveWorkbook
            For j = .Worksheets.Count To 1 Step -1
              If .Worksheets(j).Name = feuille Then
                With Worksheets(j)
                  With .Columns(param_des_fichiers(i, 4)).Cells(1, 1)
                    With .Parent.Range(.Cells, IIf(IsEmpty(.Cells) Or IsEmpty(.Cells.Offset(1)), .Cells, .End(xlDown)))
                      h = .Count * (1 + IsEmpty(.Cells(1, 1).Value))
                    End With
                  End With
                  If h Then
                    For k = 4 To UBound(v)
                      If Not IsEmpty(param_des_fichiers(i, k)) Then v(k) = .Columns(param_des_fichiers(i, k)).Cells(1, 1).Resize(h).Cells
                    Next
                  End If
                End With
                Exit For
              End If
            Next j
            .Close
          End With
          If j Then
            With ThisWorkbook.Sheets("RECAP").[A2].Offset(n)
                If h Then
                    For k = 5 To UBound(v): .Offset(, k - 5).Resize(h).Value = v(k): Next
                    n = n + h
                Else
                    msg = msg & vbLf & "Il n'y a pas de données dans la feuille """ & feuille & """ du classeur " & vbLf & Chr(9) & """" & fichier & """."
                End If
            End With
          Else
            msg = msg & vbLf & "Il n'y a pas de feuille """ & feuille & """ dans le classeur " & vbLf & Chr(9) & """" & fichier & """."
          End If
        End If
        cf = Dir
      Loop
      If tf Then msg = msg & vbLf & "Il n'existe pas de chemin " & vbLf & Chr(9) & """" & chemin & fichier & """."
      End If
    Next i
  Else
    msg = msg & vbLf & "Il n'y a aucun dossier à traiter."
  End If

  ThisWorkbook.Sheets("RECAP").Activate
Fa:
  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
  If msg <> "" Then MsgBox msg, vbInformation
Exit Sub

Ea:
  If Not (ActiveWorkbook Is ThisWorkbook) Then ActiveWorkbook.Close
  msg = "Une erreur imprévue s'est produite !"
  Resume Fa
End Sub

ℝOGER2327
#7323

Mercredi 18 Palotin 141 (Canotage - Vacuation)
18 Floréal An CCXXII, 5,8801h - corbeille-d'or
2014-W19-3T14:06:44Z

 

[waine_99]

Re : Fusion de classeurs excels

Bonjour Roger,

Merci beaucoup c'est parfait!
Je m'excuse pour le temps perdu: ma demande a malheureusement évolué...

D'ailleurs, à quoi correspondent les dates de modification "18 Floréal CCXXII"?

 

[ROGER2327]

Re : Fusion de classeurs excels

Re...

(...) à quoi correspondent les dates de modification "18 Floréal CCXXII"?

Ces dates sont celles où j'ai créé ou modifié les procédures. Étant républicain, laïque et français, j'utilise le calendrier de la République française, institué par le décret pris le 14 vendémiaire an II par la Convention nationale.
Voir ici pour quelques précisions.
Pour les calotins, j'indique en parenthèse la date papiste.​

ℝOGER2327
#7341

Lundi 23 Palotin 141 (Saints Quatrezoneilles, Herdanpo, Mousched-Gogh, Palotins - fête Suprême Quarte)
23 Floréal An CCXXII, 8,0473h - bourrache
2014-W20-1T19:18:48Z