XL 2013 Synthèse de plusieurs feuillets

alain.raphael

XLDnaute Occasionnel
Bonjour à Tous,

J'ai besoin de faire une synthèse de plusieurs feuillets..... Ces feuillets sont incrémentés jour après jour.
Je n'arrive pas à synthétiser ces données (par exemple par date) sur un feuillet unique.

Je ne sais pas si l'on doit forcément passer par du matriciel....

Je vous laisse un exemple ci-dessous.

Merci pour vos idées...
 

Pièces jointes

  • Synthese données feuillets.xlsx
    12.5 KB · Affichages: 88

job75

XLDnaute Barbatruc
Bonjour raphael,

Par formules c'est sûrement compliqué, par VBA c'est assez simple.

Voyez le fichier joint et le code de la feuille "Synthèse" (clic droit sur l'onglet et Visualiser le code) :
Code:
Private Sub Worksheet_Activate()
Dim lig&, w As Worksheet
Application.ScreenUpdating = False
lig = 5 '1ère ligne à renseigner
For Each w In Worksheets
  If w.Name Like "Centre*" Then 'critère à adapter éventuellement
    With w.[B4].CurrentRegion.Offset(1)
      Cells(lig, 2).Resize(.Rows.Count) = .Columns(1).Value
      Cells(lig, 3).Resize(.Rows.Count) = w.Name
      Cells(lig, 4).Resize(.Rows.Count, 3) = .Columns(2).Resize(, 3).Value
      lig = lig + .Rows.Count - 1
    End With
  End If
Next
Range("B" & lig & ":F" & Rows.Count).ClearContents 'RAZ
[B4].CurrentRegion.Sort [B4], xlAscending, [C4], , xlAscending, Header:=xlYes 'tri sur les dates
End Sub
La macro se déclenche quand on active la feuille.

A+
 

Pièces jointes

  • Synthese données feuillets(1).xlsm
    28 KB · Affichages: 73

alain.raphael

XLDnaute Occasionnel
Re Job,

J'ai changé un peu ma formule car le feuille synthèse commence à la ligne 20, et mes données sur Feuillets commencent à la B147 (B146 titre tableau) :



Private Sub Worksheet_Activate()
Dim lig&, w As Worksheet
Application.ScreenUpdating = False
lig = 20 '1ère ligne à renseigner
For Each w In Worksheets
If w.Name Like "CS *" Then 'critère à adapter éventuellement
With w.[B146].CurrentRegion.Offset(1)
Cells(lig, 2).Resize(.Rows.Count) = .Columns(1).Value
Cells(lig, 3).Resize(.Rows.Count) = w.Name
Cells(lig, 4).Resize(.Rows.Count, 3) = .Columns(2).Resize(, 3).Value
lig = lig + .Rows.Count - 1
End With
End If
Next
Range("B" & lig & ":F" & Rows.Count).ClearContents 'RAZ
'J'ai enlevé le tri car je pourrais toujours filtrer plus tard
End Sub


Ma MFC des Centres est celui-ci ci-dessous:

Du coup, il me prend aussi le titre du tableau dans mon feuillet synthèse..... Une idée ?

(Par contre il mets beaucoup de temps lorsque j'ouvre la synthèse, faut dire que j'ai 50 feuillets de Centre......je pense que c'est çà :rolleyes:)
 

Pièces jointes

  • Sans titre.png
    Sans titre.png
    44.2 KB · Affichages: 61
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour alain.raphael, le forum,

Avec de nombreuses feuilles on gagne du temps en utilisant des tableaux VBA :
Code:
Private Sub Worksheet_Activate()
Dim w As Worksheet, nom$, a, t(), i&, j&, h&
Application.ScreenUpdating = False
For Each w In Worksheets
  nom = w.Name
  If nom Like "CS*" Then 'critère à adapter éventuellement
    With w.[B146].CurrentRegion.Offset(1).Resize(, 4)
      a = .Value2 '.Value2 important pour les dates
      ReDim Preserve t(1 To 5, 1 To h + .Rows.Count) 'tableau transposé
    End With
    For i = 1 To UBound(a) - 1
      j = h + i
      t(1, j) = a(i, 1)
      t(2, j) = nom
      t(3, j) = a(i, 2)
      t(4, j) = a(i, 3)
      t(5, j) = a(i, 4)
    Next
    h = h + i - 1
  End If
Next
Range("B20:F" & Rows.Count).ClearContents 'RAZ
If h Then
  [B20].Resize(h, 5) = Application.Transpose(t) 'avec Transpose maximum 65536 lignes
  [B20].Resize(h, 5).Sort [B20], xlAscending, [C20], , xlAscending, Header:=xlNo 'tri sur les dates
End If
End Sub
Fichier (2).

Pour les MFC j'ai bien indiqué dès le fichier (1) qu'il fallait les appliquer aux colonnes entières.

A+
 

Pièces jointes

  • Synthese données feuillets(2).xlsm
    29.2 KB · Affichages: 34

job75

XLDnaute Barbatruc
Re,

Si le tableau de synthèse a plus de 65536 lignes on ne peut plus utiliser Application.Transpose.

Il faut faire la transposition avec des boucles :
Code:
  ReDim a(1 To h, 1 To 5)
  For i = 1 To h
    For j = 1 To 5
      a(i, j) = t(j, i)
  Next j, i
  [B20].Resize(h, 5) = a
Fichier (2 bis).

A+
 

Pièces jointes

  • Synthese données feuillets(2 bis).xlsm
    29.4 KB · Affichages: 25

job75

XLDnaute Barbatruc
Re,

Pour tester j'ai créé 50 feuilles "CS" identiques avec chacune un tableau de 999 lignes.

Durées d'exécution sur Win 10 - Excel 2013 :

- macro du fichier (1) => 0,84 seconde

- macro du fichier (2) => 1,20 seconde

- macro du fichier (2 bis) => 1,02 seconde.

Les tableaux VBA ne font rien gagner, il faudrait beaucoup plus de feuilles pour qu'ils deviennent intéressants.

Je ne comprends vraiment pas pourquoi la solution du fichier (1) prend du temps chez vous.

Auriez-vous d'autres macros évènementielles dans la feuille "Synthèse" ? Ou des formules matricielles ?

A+
 

job75

XLDnaute Barbatruc
Bonjour alain.raphael, le forum,
Auriez-vous d'autres macros évènementielles dans la feuille "Synthèse" ? Ou des formules matricielles ?
Dans ce cas il suffit de compléter la 1ère solution comme ceci :
Code:
Private Sub Worksheet_Activate()
Dim lig&, w As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
lig = 20 '1ère ligne à renseigner
For Each w In Worksheets
  If w.Name Like "CS*" Then 'critère à adapter éventuellement
    With w.[B146].CurrentRegion.Offset(1)
      Cells(lig, 2).Resize(.Rows.Count) = .Columns(1).Value
      Cells(lig, 3).Resize(.Rows.Count) = w.Name
      Cells(lig, 4).Resize(.Rows.Count, 3) = .Columns(2).Resize(, 3).Value
      lig = lig + .Rows.Count - 1
    End With
  End If
Next
Range("B" & lig & ":F" & Rows.Count).ClearContents 'RAZ
[B19].CurrentRegion.Sort [B19], xlAscending, [C19], , xlAscending, Header:=xlYes 'tri sur les dates
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Fichier (1 bis).

Bonne journée.
 

Pièces jointes

  • Synthese données feuillets(1 bis).xlsm
    28.9 KB · Affichages: 40
Dernière édition:

alain.raphael

XLDnaute Occasionnel
Merci pour toutes ces réponses.....

J'avais arrangé le 1er code comme ceci....que j'avais relié à un bouton :

Private Sub Bouton4_Cliquer()
Dim lig&, w As Worksheet
Application.ScreenUpdating = False
lig = X '1ère ligne à renseigner
For Each w In Worksheets
If w.Name Like "CS *" Then 'critère à adapter éventuellement
With w.[BX].CurrentRegion.Offset(2)
Cells(lig, 2).Resize(.Rows.Count) = .Columns(1).Value
Cells(lig, 3).Resize(.Rows.Count) = w.Name
Cells(lig, 4).Resize(.Rows.Count, 3) = .Columns(2).Resize(, 3).Value
lig = lig + .Rows.Count - 2
End With
End If
Next
Range("B" & lig & ":F" & Rows.Count).ClearContents 'RAZ

End Sub


Et tout est parfait !!!

Merci encore !!
 

alain.raphael

XLDnaute Occasionnel
Oui 2 lignes de titres .....

Par contre niveau rapidité, j'ai finalement opté pour mettre ces tableaux dans d'autres feuillets plus proche (genre 15ème cellule) (initialement 146 ).
En effet, se trouvaient avant ces tableaux cellule 0 à 145 dans chaque feuillet un formulaire avec des cases à cocher. Je penses que ces derniers me ralentissaient l’exécution de la macro.

Car question rapidité PC, le mien est tout neuf....on ne peut mieux faire :(
 

job75

XLDnaute Barbatruc
Re,
Par contre niveau rapidité, j'ai finalement opté pour mettre ces tableaux dans d'autres feuillets plus proche (genre 15ème cellule) (initialement 146 ).
En effet, se trouvaient avant ces tableaux cellule 0 à 145 dans chaque feuillet un formulaire avec des cases à cocher. Je penses que ces derniers me ralentissaient l’exécution de la macro.
La position des tableaux n'a strictement aucune importance.

Et vos "formulaires" (???) non plus si vous ajoutez les Application.EnableEvents et les Application.Calculation de mon post #8.

A+
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 909
Membres
101 836
dernier inscrit
karmon