XL 2013 Synthèse de plusieurs feuillets

[alain.raphael]

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...

 

[job75]

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) :

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+

 

[alain.raphael]

Merci pour la qualité de la réponse...... c'est exactement ce que je recherchais......

🙂

 

[alain.raphael]

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 çà 🙄)

 

[job75]

Bonjour alain.raphael, le forum,

Avec de nombreuses feuilles on gagne du temps en utilisant des tableaux VBA :

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+

 

[job75]

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 :

  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+

 

[job75]

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]

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 :

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.

 

[alain.raphael]

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 !!

 

[job75]

Re,

Ah bon d'accord s'il y a 2 lignes de titres.

Mais vous avez parlé de rapidité, qu'en est-il finalement ?

A+

 

[alain.raphael]

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]

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+