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

Broch002 · 16 Mai 2012

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

david84 · 18 Mai 2012

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

Re
test effectué sur Excel 2007 : fonctionne si l'on remplace "xlPivotTableVersion14" par "xlPivotTableVersion12".
Temps de consolidation : 0,6 sec.
A+

Broch002 · 18 Mai 2012

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

Bonjour, david84,

La macro1 de mapomme accélère la procédure dans mon fichier qui à actuellement 14500 lignes,20 secondes au lieu d'une minute mais très loin des 0.6 secondes que tu as réalisés.
J'ai tester ta modification en remplaçant "xlPivotTableVersion14" par "xlPivotTableVersion12" dans la macro2 de mapomme, il y toujours l'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+

Broch002

mapomme · 18 Mai 2012

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

(re) Bonjour david84 et le Forum,

Je te remercie du déverminage en 2007. Pour 2010, il faut que je planche encore; c'est d'autant plus bizarre que ça marchait chez moi puis en réessayant j'ai un échec. Il faut que je m'aguerrisse à la prog. des TCD !

pierrejean · 18 Mai 2012

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

Bonjour à tous

Dedié à mon ami David

Un essai

Broch002 · 18 Mai 2012

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

re bonjour, david84

J'ai tesT2 ta modification en remplaçant "xlPivotTableVersion14" par "xlPivotTableVersion12" dans la macro "SST_Realisation" sur le fichier d'origine test v2 et la macro fonctionne environ 5 fois sur 10 (ce n'est pas systématique, la Macro Plante à cette ligne : With .PivotTables("TCD_Real").PivotFields("CT_INTITULE") avec ce message "il y l'erreur d'exécution 1004 : Impossible de lire la propriété PivotFields de la classe PivoTable" mais pourtant je ne fais rien et je ne change rien

En essayant de l'adapter à une feuille avec plus de colonne (A:M) à la place de (A:F) il y systématiquement l'erreur d'exécution 1004 : Impossible de lire la propriété PivotFields de la classe PivoTable et la Macro replante à la ligne : With .PivotTables("TCD_Real").PivotFields("CT_INTITULE")

Voici la macro modifier:

Sub SST_Realisation()
Dim xrg As Range, Deb, sFrom, sTo, s

Sheets("Réalisation").Activate
With Sheets("Réalisation")
Deb = Timer
.Columns("A:M").Clear
Application.ScreenUpdating = False
sFrom = Sheets("A-1").Range("A:M").Address(True, True, xlR1C1, True)
sTo = .Name & "!" & "R1C1"

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=sFrom, _
Version:=xlPivotTableVersion12).CreatePivotTable _
TableDestination:=sTo, TableName:="TCD_Real", _
DefaultVersion:=xlPivotTableVersion12

With .PivotTables("TCD_Real").PivotFields("CT_INTITULE")
.Orientation = xlRowField
.Position = 1
End With

.PivotTables("TCD_Real").AddDataField ActiveSheet. _
PivotTables("TCD_Real").PivotFields("qte"), "Somme de qte", xlSum

.PivotTables("TCD_Real").AddDataField ActiveSheet. _
PivotTables("TCD_Real").PivotFields("mt"), "Somme de mt", xlSum

.PivotTables("TCD_Real").AddDataField ActiveSheet. _
PivotTables("TCD_Real").PivotFields("Marge"), "Somme de Marge", xlSum

.Columns("A:M").Copy
.Columns("A:M").PasteSpecial xlPasteValues
Application.CutCopyMode = False

With .Range(.Range("L1"), .Range("L" & Rows.Count).End(xlUp)).Offset(, 1)
.FormulaR1C1 = "=RC[-1]/RC[-2]"
.Style = "Percent"
.NumberFormat = "0.00%"
End With

.Range(.Range("M1"), .Range("M" & Rows.Count).End(xlUp)).Copy
.Range(.Range("M1"), .Range("M" & Rows.Count).End(xlUp)).PasteSpecial xlPasteValues

.Range("A1") = "CT_INTITULE"
.Range("J1") = "QTE"
.Range("K1") = "MT"
.Range("L1") = "Marge"
.Range("M1") = "Marge (%)"

Sheets("A-1").Range("A1").Copy
.Range("A1:M1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
.Columns("A:M").EntireColumn.AutoFit

End With

Application.ScreenUpdating = True
s = Format(Timer() - Deb, "0.0 secondes")
MsgBox "Consolidation 'Réalisation' actualisée!" & vbLf & "==> " & s
End Sub

Merci de votre aide.:

david84 · 18 Mai 2012

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

Re
Je n'ai fait que tester le fichier puisque mapomme l'avait demandé. Puisque c'est lui qui est en train de te proposer cette solution, je ne fais que lui fournir mes retours de test.
D'ailleurs, je te signale qu'il passe par un TCD alors que dans ton message 1, tu avais précisé

je ne peux pas passer par un tableau croisé dynamique

Personnellement, je trouve pourtant que le TCD sans passer par une macro était la solution la plus simple. Ceci-dit, à partir du moment où la situation oblige à passer par une macro, j'aurais plutôt opté a priori par un code utilisant Dictionary comme te l'a proposé mon ami pierrejean

.
Je serais d'ailleurs curieux que tu nous dises quel est le temps de traitement de la macro proposée par pierrejean.
A+

mapomme · 18 Mai 2012

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

Bonsoir à Broch02, David 84, pierrejean et le Forum

1) j'ai testé la macro de pierrejean et comme on pouvait s'y attendre c'est une solution hyper rapide : 0,5 s pour 50000 lignes et 500 références et le code est bien plus limpide avec un dictionary que le code pour un TCD.

2) j'avais noté que Broch02 ne désirait pas de TCD. Aussi il m'est venu l'idée de cacher le TCD par une macro VBA et de programmer un TCD via VBA (ce que je n'avais encore point fait). Mes premiers pas ne sont pas concluants!

il y a quelque chose que je n'ai pas encore bien saisi dans l'organisation des différents objets relatifs aux TCD, mais je persévère

Broch002 · 20 Mai 2012

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

Bonjour, mapomme, David 84, pierrejean et le Forum

excuser-moi pour cette pause weel-end.

Lors de mon dernier envoi, j'essayais d'adapter la macro de mapomme à d'autres feuilles du fichier. je n'avais pas essayé celle de pierrejean, elle fonctionne impécable.
pierrejean, serait il possible, étant profane sur le type de macro que vous avez utilisé, de me l'adapter à mon dernier fichier comportant 13 colonnes qui doivent être également trier. j'essaierais de comprendre les différences entre vos deux macro de manière, après compréhension, a clore se sujet.

Merci d'avance et bon dimanche.

Broch002.

mapomme · 20 Mai 2012

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

Bonjour à tous,

Testez la macro:

Code:

Sub test()
Application.ScreenUpdating = False
Rows("1:1").AutoFilter
Set dico1 = CreateObject("scripting.dictionary")
Set dico2 = CreateObject("scripting.dictionary")
Set dico3 = CreateObject("scripting.dictionary")
tablo = Range("A2:L" & Range("A" & Rows.Count).End(xlUp).Row)
For n = LBound(tablo, 1) + 1 To UBound(tablo, 1)
  x = tablo(n, 1)
  dico1(x) = dico1(x) + tablo(n, 10)
  dico2(x) = dico2(x) + tablo(n, 11)
  dico3(x) = dico3(x) + tablo(n, 12)
Next n
a = dico1.keys
b1 = dico1.items
b2 = dico2.items
b3 = dico3.items
ligne = 2
Range(Sheets("Feuil1").Cells(2, "a"), _
   Sheets("Feuil1").Cells(Rows.Count, "e")).ClearContents
For n = LBound(a) To UBound(a)
  Sheets("Feuil1").Cells(ligne, 1) = a(n)
  Sheets("Feuil1").Cells(ligne, 2) = b1(n)
  Sheets("Feuil1").Cells(ligne, 3) = b2(n)
  Sheets("Feuil1").Cells(ligne, 4) = b3(n)
  Sheets("Feuil1").Cells(ligne, 5) = b3(n) / b2(n)
  ligne = ligne + 1
Next n

Sheets("Feuil1").Range("A1").CurrentRegion.Sort _
   key1:=Sheets("Feuil1").Range("A1"), _
   order1:=xlAscending, Header:=xlYes
Application.ScreenUpdating = True
Sheets("feuil1").Select
End Sub

david84 · 20 Mai 2012

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

Bonjour,
Ci-joint une autre macro utilisant Transpose, ce qui te divise le temps de traitement par 2 mais attention, sur 2007 transpose n'est opérationnel que jusqu'à 65000 lignes je crois (mais bon, le nombre de valeurs ramenées par les dictionnaires dans ton exemple sont de 500, donc tu as de la marge).

Code:

Sub Test()
debut = Timer
Set dico1 = CreateObject("scripting.dictionary")
Set dico2 = CreateObject("scripting.dictionary")
Set dico3 = CreateObject("scripting.dictionary")
Tablo = Sheets("A-1").Range("A2:L" & Sheets("A-1").Range("A" & Rows.Count).End(xlUp).Row)
For i = LBound(Tablo, 1) To UBound(Tablo, 1)
  dico1(Tablo(i, 1)) = dico1(Tablo(i, 1)) + Tablo(i, 10)
  dico2(Tablo(i, 1)) = dico2(Tablo(i, 1)) + Tablo(i, 11)
  dico3(Tablo(i, 1)) = dico3(Tablo(i, 1)) + Tablo(i, 12)
Next i
With Sheets("Feuil1")
    '.AutoFilterMode = False 'si l'on veut les filtres
    .Range("A2:E" & UBound(Tablo) + 1).ClearContents
    .[A2].Resize(dico1.Count) = Application.Transpose(dico1.keys)
    .[b2].Resize(dico1.Count) = Application.Transpose(dico1.items)
    .[C2].Resize(dico2.Count) = Application.Transpose(dico2.items)
    .[D2].Resize(dico3.Count) = Application.Transpose(dico3.items)
    For i = 2 To dico1.Count + 1
        .Cells(i, 5) = .Cells(i, 4) / .Cells(i, 3)
    Next i
    '.[A2].Sort Key1:=[A2], Order1:=xlAscending, Header:=xlGuess'si l'on veut trier les noms par ordre alpha
    '.Range(Cells(1, 1), Cells(1, UBound(Tablo, 2) - 1)).AutoFilter 'si l'on veut les filtres
    .Activate
End With
MsgBox (Timer - debut)
End Sub

Teste et dis-nous.
A+

Si... · 20 Mai 2012

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

salut tous

Si... tu veux tester cette version sans superflu, dis-nous ce que tu constates

Code:

Sub test()
    Set dico1 = CreateObject("scripting.dictionary")
    Set dico2 = CreateObject("scripting.dictionary")
    Set dico3 = CreateObject("scripting.dictionary")
    tablo = Range("A2:L" & Range("A" & Rows.Count).End(xlUp).Row)
    For n = 1 To UBound(tablo, 1)
        x = tablo(n, 1)
        dico1(x) = tablo(n, 10)
        dico2(x) = tablo(n, 11)
        dico3(x) = tablo(n, 12)
    Next
    a = dico1.keys
    b1 = dico1.items
    b2 = dico2.items
    b3 = dico3.items
    Sheets("Feuil1").Select
    For n = LBound(a) To UBound(a)
        Cells(2 + n, 1) = a(n)
        Cells(2 + n, 2) = b1(n)
        Cells(2 + n, 3) = b2(n)
        Cells(2 + n, 4) = b3(n)
        Cells(2 + n, 5) = b3(n) / b2(n)
    Next
    Range("A2:E" & Cells(Rows.Count, 1).End(xlUp).Row).Sort Range("A1"), 1
End Sub

Broch002 · 20 Mai 2012

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

Bonjour, David84.

J'ai testé la macro sur le fichier broch_test, avec des croix dans les colonnes c à i, et elle fonctionne.
Quand je la test sur mon fichier (colonnes renseignées), la macro se met en erreur sur la ligne ".Cells(i, 5) = .Cells(i, 4) / .Cells(i, 3)".

Merci de votre persévérance.
Est il possible sur la feuil1 d'avoir toutes les lignes et colonnes de la feuilles réalisation, trier de la * grande valeur de la colonne J (Qte) a la plus petite.

Je test les autres propositions.

Merci à tous et au forum, bonne soirée.

Broch002.

david84 · 20 Mai 2012

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

Re

J'ai testé la macro sur le fichier broch_test, avec des croix dans les colonnes c à i, et elle fonctionne.
Quand je la test sur mon fichier (colonnes renseignées), la macro se met en erreur sur la ligne ".Cells(i, 5) = .Cells(i, 4) / .Cells(i, 3)".

Si cela fonctionne sur le fichier test et pas dans ton fichier original, c'est qu'il y a quelque chose qui différencie les 2 fichiers mais je ne sais pas quoi...es-tu sûr que les colonnes 3 à 5 contiennent les mêmes types de données ?

Est il possible sur la feuil1 d'avoir toutes les lignes et colonnes de la feuilles réalisation, trier de la * grande valeur de la colonne J (Qte) a la plus petite.

Je n'ai pas tout suivi depuis le début mais je ne vois pas à quoi te sert la feuille réalisation puisque les données de la feuille A-1 sont traitées dans "Feuil1". Que veux-tu obtenir exactement dans la feuille Réalisation ? Si tu as besoin de 2 feuilles distinctes (Réalisation et Feuil1), c'est que tu dois avoir 2 traitements distincts à effectuer mais pour l'instant je ne comprends pas.
Concernant le tri, si tu le veux dans "Feuil1", il te suffit de décocher le rem (') placé devant

Code:

'.[A2].Sort Key1:=[A2], Order1:=xlAscending, Header:=xlGuess'si l'on veut trier les noms par ordre alpha

Remplace le A de [A2] par la colonne que tu veux filtrer et xlAscending par xlDescending si tu veux obtenir un tri par ordre décroissant.
Ci-joint un lien te permettant de comprendre la méthode Sort si tu veux l'utiliser sur une autre feuille.
A+

Broch002 · 21 Mai 2012

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

Bonjour, David84, pierrejean, ma pomme et le forum.

Le fichier joint en exemple ne comptait que 6 colonnes pour l’alléger, mais l'original en a 17.
Cette feuille est intégrée dans un classeur et sert de base de données d'où la création d'une autre feuille pour visualiser les informations recherchées par l'utilisateur.Le Classeur est mis à jour journellement. Voici le détail des informations de chaque colonne:
Colonnes 1, 2, 4, 5, 6, 7, 8, 9 et 13 sont du texte.
Colonne 3, des dates.
Colonnes 10,11, 12 des nombres.
Cellules N1, O1, P1 des colonnes 14, 15, 16 sont des formules totalisant les sous-totaux respectivement les colonnes 10 11 et 12.
Cellule Q1 de la colonne 17 la date de la dernière mise à jour.
L'utilisateur au travers d' userforms choisit les critères à visualiser sur la feuille "Réalisation" de lecture (Feuil1 de pierrejean) du fichier-test.
Les critères de trie lancés par l'userform sont:
Par nom, colonne a (exemple du fichier-test)
Par dates, colonne B
Par réseau, colonne C
Par nom de collaborateur, colonne D etc...
Seules les colonnes J, K et L (les nombres) ne servent pas de critères de trie.
Les informations remontées dans la feuille temporaire sont mises en page par la Macro.
Actuellement j'utilise une macro enregistrée par l'enregistreur d'Excel des sous-totaux de l'onglet donnée, et c'est trop long pour être exploité pour de gros fichiers, plus de 2 minutes.

La feuille réalisation est celle du fichier-test. qui n'a pas été utilisée par pierrejean qui à renseigné la feuil1, elles font doublon dans l'exemple, mais le classeur en comporte une dizaine en fonction des critères demandés par l'utilisateur, ce qui lui permet de jongler entre les feuilles au besoin.

je vous joins un le fichier-test visualisant un exemple de ce que je viens de vous décrire, avec la feuille "réalisation" mise ne page.

Bonne journée, et je vous remercie du temps que vous me consacrez.

Broch002

mutzik · 21 Mai 2012

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

bonjour,

ou comment se passer de TCD ...

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

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums