XL 2010 Consolider plusieurs feuilles (classeurs) identiques par VBA

fattah_5791

XLDnaute Occasionnel
Bonsoir tout le monde,

merci de m'aider à surmonter mon petit probleme.

j'ai une dizaine de classeurs (chq classeur contient une seule feuille) identiques que je veux consolider par VBA. les cellules de la plage A1:H250 de toutes les feuilles à consolider contiennent des valeurs numeriques. je veux faire la somme des cellules A1 de ttes les feuilles et la mettre ds la cellule A1 d'une feuille RECAP et de meme pour B1, C1,...., H250.

Merci de votre aide
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil,

fattah_5791
Poser des questions c'est bien
Se souvenir qu'on a déjà posé la question, c'est mieux ;)
Suivre la question qu'on a jadis posée et réagir aux réponses, c'est encore mieux ;)
(Mais ne pas attendre trois ans pour le faire ;))
 

Calvus

XLDnaute Barbatruc
Bonjour le forum,

Voici, en tenant compte de tes remarques, à savoir structure identique sur tous les classeurs.

Il faut renseigner les noms des classeurs à partir de "A2", en mettant le chemin complet.
Puis appuyer sur le bouton Consolidation.

Testé sur 3 et 4 classeurs.

Les sommes seront affichées dans la feuille Résultat.

VB:
Option Explicit

Sub Consolidation()
Dim i As Long, j As Integer, n As Long, k As Integer, m As Integer, total As Integer
Application.ScreenUpdating = False
Sheets("Calculs").[A1].CurrentRegion.ClearContents
Call Ouverture_Classeur
Sheets("Calculs").Activate
Application.Calculation = xlCalculationManual
m = 0
For j = 1 To 8
    For i = 1 To 250
        n = 251
        n = n + m
        total = Cells(i, j) + Cells(n, j)
            For k = 1 To Application.CountA(Sheets("Matrice").Range("A:A")) - 1
                n = n + 250
                total = total + Cells(n, j)
            Next k
        Sheets("Résultat").Cells(i, j) = total
        m = m + 1
    Next i
    m = 0
Next j
'Application.FileDialog(msoFileDialogFolderPicker).Show ' Ouverture boite de dialogue
Application.Calculation = xlCalculationAutomatic

Sheets("Résultat").Activate

Application.ScreenUpdating = True
End Sub

Sub Ouverture_Classeur()
Dim fichier As String, i As Byte, Flag As Boolean


For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
fichier = Cells(i, 1)
On Error Resume Next
    Workbooks(fichier).Activate
    If Err.Number <> 0 Then
        Workbooks.Open fichier
    End If

If Flag = False Then
    [A1].CurrentRegion.Copy Destination:=ThisWorkbook.Sheets("Calculs").Range("A" & Rows.Count).End(xlUp)
Else
    [A1].CurrentRegion.Copy Destination:=ThisWorkbook.Sheets("Calculs").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If

Flag = True
ActiveWorkbook.Close
Next i
End Sub

A+
 

Pièces jointes

  • Matrice.xlsm
    65.5 KB · Affichages: 25
  • tatata.xlsx
    17 KB · Affichages: 14
  • tototo.xlsx
    17 KB · Affichages: 16
  • tititi.xlsx
    17 KB · Affichages: 12
  • tututu.xlsx
    17 KB · Affichages: 16

Staple1600

XLDnaute Barbatruc
Bonjour Calvus

Non, je trouve toujours dommage quand un demandeur ne fait pas un retour quand il a une réponse à une question posée...

Et tes PJ pourront servir à d'autres lecteurs du fil.

PS: D'ou sors-tu le nom des feuilles des classeurs?
Vu que le demandeur n'a pas joint de fichier exemple...
 

job75

XLDnaute Barbatruc
Bonjour fattah_5791, JM, Calvus,

10 classeurs à consolider ce n'est pas la mer à boire, pas besoin de VBA, il suffit d'utiliser des formules de liaison.

Ouvrez tous les fichiers à consolider et le fichier Consolidation.xlsx.

En A1 de ce dernier fichier entrez la formule comme ici avec 4 fichiers :
Code:
=[tatata.xlsx]Feuil1!A1+[tututu.xlsx]Feuil1!A1+[tototo.xlsx]Feuil1!A1+[tititi.xlsx]Feuil1!A1
Vous pouvez maintenant fermer les fichiers sources et tirer la formule à droite et vers le bas pour remplir A1:H250.

Fichiers joints, téléchargez-les dans le même répertoire (le bureau).

A+
 

Pièces jointes

  • Consolidation(1).xlsx
    86.3 KB · Affichages: 13
  • tatata.xlsx
    17 KB · Affichages: 11
  • tututu.xlsx
    17 KB · Affichages: 7
  • tototo.xlsx
    17 KB · Affichages: 8
  • tititi.xlsx
    17 KB · Affichages: 7

job75

XLDnaute Barbatruc
Bonjour le forum,

Les manipulations indiquées au post précédent peuvent bien sûr se faire par VBA :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
'---ouverture des fichiers---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        f = f & IIf(f = "", "=", "+") & "'[" & fichier & "]" & Workbooks.Open(chemin & fichier).Sheets(1).Name & "'!A1"
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With ThisWorkbook.Sheets(1).[A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
'---fermeture des fichiers---
For Each wb In Workbooks
    If wb.Name <> ThisWorkbook.Name Then wb.Close False
Next
Application.ScreenUpdating = True
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Fichiers joints, chez moi sur Win 10 - Excel 2013 la consolidation des 4 fichiers se fait en 2,4 secondes.

A+
 

Pièces jointes

  • Consolidation VBA(1).xlsm
    22.7 KB · Affichages: 17
  • tatata.xlsx
    17 KB · Affichages: 13
  • tititi.xlsx
    17 KB · Affichages: 12
  • tototo.xlsx
    17 KB · Affichages: 10
  • tututu.xlsx
    17 KB · Affichages: 10

job75

XLDnaute Barbatruc
Bonjour le forum,

Si le nom de la feuille est toujours le même, il n'est pas nécessaire d'ouvrir les fichiers :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nomfeuil$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
nomfeuil = "Feuil1" 'nom à adapter
'---formule concaténée---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        f = f & IIf(f = "", "='", "+'") & chemin & "[" & fichier & "]" & nomfeuil & "'!A1"
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With [A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Fichiers joints, consolidation des 4 fichiers en 0,11 seconde chez moi.

Bonne journée.
 

Pièces jointes

  • Consolidation VBA(2).xlsm
    22.3 KB · Affichages: 8
  • tatata.xlsx
    17 KB · Affichages: 5
  • tititi.xlsx
    17 KB · Affichages: 6
  • tototo.xlsx
    17 KB · Affichages: 6
  • tututu.xlsx
    17 KB · Affichages: 6

fattah_5791

XLDnaute Occasionnel
Bonjour le forum,

Les manipulations indiquées au post précédent peuvent bien sûr se faire par VBA :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
'---ouverture des fichiers---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        f = f & IIf(f = "", "=", "+") & "'[" & fichier & "]" & Workbooks.Open(chemin & fichier).Sheets(1).Name & "'!A1"
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With ThisWorkbook.Sheets(1).[A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
'---fermeture des fichiers---
For Each wb In Workbooks
    If wb.Name <> ThisWorkbook.Name Then wb.Close False
Next
Application.ScreenUpdating = True
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Fichiers joints, chez moi sur Win 10 - Excel 2013 la consolidation des 4 fichiers se fait en 2,4 secondes.

A+
Merci Job 75, C'est ce que je cherche à mon truc. avec qlqs adaptations, je suis arrivé à regler mon prblm.
 

fattah_5791

XLDnaute Occasionnel
Bonjour le forum,

Si le nom de la feuille est toujours le même, il n'est pas nécessaire d'ouvrir les fichiers :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nomfeuil$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
nomfeuil = "Feuil1" 'nom à adapter
'---formule concaténée---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        f = f & IIf(f = "", "='", "+'") & chemin & "[" & fichier & "]" & nomfeuil & "'!A1"
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With [A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Fichiers joints, consolidation des 4 fichiers en 0,11 seconde chez moi.

Bonne journée.
Je considère que mon truc est résoulu avec un grand merci à tous les intervenants.
 

fattah_5791

XLDnaute Occasionnel
Bonjour le forum,

Si le nom de la feuille est toujours le même, il n'est pas nécessaire d'ouvrir les fichiers :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nomfeuil$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
nomfeuil = "Feuil1" 'nom à adapter
'---formule concaténée---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        f = f & IIf(f = "", "='", "+'") & chemin & "[" & fichier & "]" & nomfeuil & "'!A1"
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With [A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Fichiers joints, consolidation des 4 fichiers en 0,11 seconde chez moi.

Bonne journée.
merci job75 pour votre aide, juste est il possible de proceder ainsi:
pour eviter que tous les classeurs (en realité j aurai une centaine de classeurs source identiques) soient ouverts en meme temps, est il possible:
- d'ouvrir en arrière plan le premier classeur source puis de copier les valeurs ds le classeur de destination,
- fermer le 1er classeur ouvet,
- ouvrir le 2eme classeur source,
- copier les valeurs du 2eme classeur source et les rajouter aux valeurs du classeur destination,
- fermer le 2eme classeur source,
- ouvrir le 3eme classeur source,
- copier les valeurs du 3eme classeur source et les rajouter aux valeurs du classeur destination,
- ainsi de suite....

comme ca la memoire ne sera pas trop occupée

Merci encore
 

job75

XLDnaute Barbatruc
Bonjour fattah_5791, le forum,

100 classeurs ça commence à faire... Avec la macro du post #10 on n'ouvre pas les fichiers, c'est bien plus rapide.

Mais on peut en effet modifier la macro du post #9, fichier (1 bis) :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
'---ouverture des fichiers---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        With Workbooks.Open(chemin & fichier)
            f = f & IIf(f = "", "='", "+'") & chemin & "[" & fichier & "]" & .Sheets(1).Name & "'!A1"
            .Close False
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With [A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
Application.ScreenUpdating = True
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Bonne journée.
 

Pièces jointes

  • Consolidation VBA(1 bis).xlsm
    22.7 KB · Affichages: 21

fattah_5791

XLDnaute Occasionnel
Bonjour fattah_5791, le forum,

100 classeurs ça commence à faire... Avec la macro du post #10 on n'ouvre pas les fichiers, c'est bien plus rapide.

Mais on peut en effet modifier la macro du post #9, fichier (1 bis) :
VB:
Sub Consolider()
Dim t#, chemin$, fichier$, nfich%, f$, wb As Workbook
t = Timer
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
'---ouverture des fichiers---
While fichier <> ""
    If fichier <> ThisWorkbook.Name Then
        nfich = nfich + 1
        With Workbooks.Open(chemin & fichier)
            f = f & IIf(f = "", "='", "+'") & chemin & "[" & fichier & "]" & .Sheets(1).Name & "'!A1"
            .Close False
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
'--remplissage du tableau---
With [A2:H251] 'plage à adapter
    .Formula = f
    .Value = .Value 'supprime les formules
End With
Application.ScreenUpdating = True
MsgBox nfich & " fichiers consolidés en " & Format(Timer - t, "0.00 \s")
End Sub
Bonne journée.
Excellent travail Job75, merci infiniment.
Comme ça mon prblm est résolu. merci encore
 

Discussions similaires

Réponses
7
Affichages
292

Statistiques des forums

Discussions
311 733
Messages
2 082 010
Membres
101 866
dernier inscrit
XFPRO