Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille.

  • Initiateur de la discussion Initiateur de la discussion Broch002
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Broch002

XLDnaute Occasionnel
Bonjour,

Je reviens vers vous, qui m'avez déjà tellement apporté de solutions.

Voila j'ai un classeur pouvant contenir 487 références sur 50 000 lignes. Je souhaites sur une autre feuilles du classeur générer des sous totaux par références (je ne peux pas passer par un tableau croisé dynamique).
Jusqu’à présent, je copiais par macro la feuille , la triais puis lançait toujours par macro la fonction sous total, mais là la macro devient terriblement longue plus le nombre de ligne et de référence augmentent.

j'ai chercher sur la toile et découvert la fonction array qui augmenterait énormément le vitesse des macros. J'ai téléchargé un fichier test et essayé de l'adapter à mon problème, mais je n'y arrive pas. pouvez-vous m'aider?

Voici la macro qui plante:
Sub TRIER_PAR_REFERENCE()
'macro trouvée sur Internet et modifié
Dim Tblo1() As Variant
Dim orders As ListObject
Dim Cel As Range
Dim f As Integer
Workbooks("test.xlsm").Activate
Set orders = Sheets("A-1").ListObjects("Tableau1")
For Each Cel In orders.DataBodyRange.Columns(1).Cells
If Cel.Value = "Jean" Then
f = f + 1
ReDim Preserve Tblo1(1 To 13, 1 To f)
Tblo1(1, f) = Cel.Offset(0, -2).Value
Tblo1(2, f) = Cel.Offset(0, -1).Value2
Tblo1(3, f) = Cel.Value
Tblo1(4, f) = Cel.Offset(0, 1).Value
Tblo1(5, f) = Cel.Offset(0, 2).Value
End If
Next Cel

With Sheets("A-1")
.Columns("H:K").Copy Destination:=Sheets("Réalisation").[B2]
End With

Workbooks("test.xlsm").Activate
Set orders = Sheets("A-1").ListObjects("Tableau1")
For Each Cel In orders.DataBodyRange.Columns(1).Cells
If Cel.Value = "Charles" Then
f = f + 1
ReDim Preserve Tblo1(1 To 13, 1 To f)
Tblo1(1, f) = Cel.Offset(0, -2).Value
Tblo1(2, f) = Cel.Offset(0, -1).Value2
Tblo1(3, f) = Cel.Value
Tblo1(4, f) = Cel.Offset(0, 1).Value
Tblo1(5, f) = Cel.Offset(0, 2).Value
End If
Next Cel

With Sheets("A-1")
.Columns("H:K").Copy Destination:=Sheets("Réalisation").[B3]
End With

Workbooks("test.xlsm").Activate
Set orders = Sheets("A-1").ListObjects("Tableau1")
For Each Cel In orders.DataBodyRange.Columns(1).Cells
If Cel.Value = "Christian" Then
f = f + 1
ReDim Preserve Tblo1(1 To 13, 1 To f)
Tblo1(1, f) = Cel.Offset(0, -2).Value
Tblo1(2, f) = Cel.Offset(0, -1).Value2
Tblo1(3, f) = Cel.Value
Tblo1(4, f) = Cel.Offset(0, 1).Value
Tblo1(5, f) = Cel.Offset(0, 2).Value
End If
Next Cel

With Sheets("A-1")
.Columns("H:K").Copy Destination:=Sheets("Réalisation").[B4]
End With

End Sub
 

Pièces jointes

Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Je suis en train de regarder.
Il y a truc qui est sûr, c'est que dans
Set orders = Sheets("A-1").ListObjects("Tableau1")
Tableau1 n'est pas un objet mais un range.
En supprimant cette ligne et en remplaçant:
For Each Cel In orders.DataBodyRange.Columns(1).Cells
Par:
For Each Cel In Sheets("A-1").Range("Tableau1")
La macro avance bien sur le For, mais il y a un autre problème ensuite (je planche dessus).
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonjour,

Merci de votre aide.
Concernant le fichier test que j'ai téléchargé, dans
"Set orders = Sheets("A-1").ListObjects("Tableau1")", "tableau1" correspond une plage nommée.
Je ne sais pas si cela peut vous aider.
Voici la macro original:

Sub Macro()
Dim Tblo1() As Variant
Dim orders As ListObject
Dim Cel As Range
Dim f As Integer
Dim StartTime As Double

Workbooks("Test.xlsm").Activate
Sheets("ex1-filtre").Columns("I:F").ClearContents
Application.ScreenUpdating = False

StartTime = Timer

Set orders = Sheets("ex1").ListObjects("tableau1")
For Each Cel In orders.DataBodyRange.Columns(3).Cells
If Cel.Value = "F76SCR036" Then
f = f + 1
ReDim Preserve Tblo1(1 To 5, 1 To f)
Tblo1(1, f) = Cel.Offset(0, -2).Value
Tblo1(2, f) = Cel.Offset(0, -1).Value2
Tblo1(3, f) = Cel.Value
Tblo1(4, f) = Cel.Offset(0, 1).Value
Tblo1(5, f) = Cel.Offset(0, 2).Value
End If
Next Cel

Sheets("ex1").Range(Cells(1, 10), Cells(f, 14)).Value = Application.WorksheetFunction.Transpose(Tblo1)
Application.ScreenUpdating = True
Sheets("ex1-filtre").Range("G10").Value = Format(Timer - StartTime, "00.00") & " secondes"
End Sud​


Broch002
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

En tout cas, quand j'essaye ce code, ça ne marche pas, donc quelques modifs ci-dessous:
Code:
For Each Cel In Sheets("A-1").Range("Tableau1")
    If Cel.Value = "Jean" Then
    b = Cel
    a = Sheets("A-1").Range("Tableau1")
    f = f + 1
 'il te sert à quoi ce tableau?
   ReDim Preserve Tblo1(1 To 13, 1 To f)
    Tblo1(1, f) = Cel.Value
    Tblo1(2, f) = Cel.Offset(0, 2).Value2
    Tblo1(3, f) = Cel.Offset(0, 3).Value
    Tblo1(4, f) = Cel.Offset(0, 4).Value
    Tblo1(5, f) = Cel.Offset(0, 5).Value
    End If
Next Cel

'C'est pour faire quoi ces 3 lignes de codes?
With Sheets("A-1")
   .Columns("H:K").Copy Destination:=Sheets("Réalisation").[B2]
   End With
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

bonjour,

Ce tableau me permet de classer les références (ici des prénoms) avec le prix moyen facturé, la marge en valeur et le coefficient. la valeur des cellules H1 à KI de la feuille A-1 (totaux des colonnes D,E,F) sont recopiés après chaque trie sur la ligne correspondante dans la feuille Réalisation.

Bonne soirée.

Broch002
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonsoir,
pourquoi ne passes-tu pas simplement par un tableau Excel avec l'utilisation d'une ligne de sous-totaux au lieu de passer par une macro ?
A+
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonsoir,

Ce fichier se mets à jour journellement et est utilisé par plusieurs personnes maîtrisant mal l'informatique.
La feuille A-1 n'est pas visible pour l'utilisateur, comme d'autre d'ailleurs, et les macros de ce fichier leurs donnent accès a des tableaux de synthèse comme celui de la feuilles réalisation, avec mise en page.

Voici pourquoi je cherche à rendre ses macros les plus rapides possibles, sachant que ces tableaux doivent être accessible rapidement.

Merci d'avance.

Bonne nuit.

Broch002
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonsoir Broch002,

Une macro en utilisant la consolidationd d'Excel.
Code:
Sub SST_Realisation()
Dim xRg As Range
Application.ScreenUpdating = False

With Sheets("Réalisation")
   .Columns("A:F").Clear
   Set xRg = Sheets("A-1").Range("A:F")
   .Range("A1").Consolidate Sources:= _
       xRg.Address(True, True, xlR1C1, True), Function:= _
       xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
   .Range("B:C").Delete xlShiftToLeft
   
   With .Range(.Range("D1"), .Range("D" & Rows.Count).End(xlUp)).Offset(, 1)
     .FormulaR1C1 = "=RC[-1]/RC[-2]"
     .Style = "Percent"
     .NumberFormat = "0.00%"
   End With
   
   .Range("E1") = "Marge (%)"
   .Range("A1") = "CT_INTITULE)"
   
    Sheets("A-1").Range("A1").Copy
    .Range("A1:E1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    .Columns("A:E").EntireColumn.AutoFit
    .Range(.Range("E1"), .Range("E" & Rows.Count).End(xlUp)) = _
         .Range(.Range("E1"), .Range("E" & Rows.Count).End(xlUp)).Value
'    .Columns("D").Delete xlShiftToLeft
End With

Application.ScreenUpdating = True
MsgBox "Consolidation 'Réalisation' actualisée!"
End Sub
 

Pièces jointes

Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

(re)Bonsoir Broch002,

Une autre version beaucoup plus rapide.

1) sur la Feuille "A-1", créer la base bidon en cliquant sur le bouton "Créer la base".

2) sur la feuille "Réalisation", cliquer sur "Actualiser".

Sur ma machine, avec 50 000 lignes et 500 noms => 0,3s.
 

Pièces jointes

Dernière édition:
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonjour à tous,

Suite au téléchargement de mon fichier Lien supprimé, j'ai eu un petit souci (ça ne fonctionnait plus sous 2010)

Une âme charitable pourrait-elle‎ me dire si cela fonctionne:
1) sur une version 2010
2) sur une version 2007
3) sur aucune des deux versions

D'avance merci,
 
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonjour,à tous.

Mersi mapomme? comme tu l'indique La version 1 donne de bon résultat sur le fichier joint, je vais le tester sur mon classeur.
Comme tu l'indiques, la version 2 bug, l'erreur est "éxlPivotTableVersion14" avec le message "erreur de compilation variable non définie".

Je vous tiens informé de l'évolution dans mon fichier.

Broch002.
 
Dernière édition:
Re : Macro Array pour accélérer des Sous totaux d'un classeur dans une autre feuille

Bonjour,
test sur Version 2010 (64 bits) :
erreur d'exécution 1004 : Impossible de lire la propriété PivotFields de la classe PivoTable
Plante à cette ligne : With .PivotTables("TCD_Real").PivotFields("CT_INTITULE")
A+
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
4
Affichages
177
Réponses
3
Affichages
665
Réponses
5
Affichages
477
Réponses
9
Affichages
580
Réponses
3
Affichages
504
Retour