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

[Broch002]

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

 

[Broch002]

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

Bonjour,

N'avez-vous pas une petite solution.

Merci d'avance.

Broch002

 

[Nairolf]

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

 

[Broch002]

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

 

[Nairolf]

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:

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

 

[Broch002]

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

 

[david84]

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+

 

[Broch002]

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

 

[mapomme]

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.

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

 

[mapomme]

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.

 

[mapomme]

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,

 

[Broch002]

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.

 

[mapomme]

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

Bonjour Broch002,

merci pour le test, je vais voir ça ce soir.

 

[david84]

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+

 

[mapomme]

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

Bonjour david84,

Merci. je vais voir.