Autres XL 2007 : Totaux de colonnes par références de lignes

erics83

XLDnaute Impliqué
Bonjour,

J'ai un "grand" tableau (jusque colonne NPY) qui traite des nomenclatures. Chaque nomenclature commence par un chiffre entre 1 et 9.
En ligne, j'ai des numéros de références ( de 1 à 4), par année et par mois.
Je cherche à obtenir les totaux pour chaque nomenclature (commençant par 1 par exemple) et pour chaque référence. Un peu comme le ferait un "SOMMEPROD", mais en nettement plus rapide vu la taille du tableau...

Je mets en PJ le classeur test simplifié
Merci pour votre aide et/ou éclairage....
 

Pièces jointes

  • Classeur Test.xlsx
    607.1 KB · Affichages: 11

erics83

XLDnaute Impliqué
Bonjour et merci nat54,

Oui, il y a un peu/beaucoup de ça....sauf que tu as pris dans le TCD "que" les 2 premières nomenclatures...alors que je cherche à avoir le total de "TOUTES" les nomenclatures commençant par 1 (par exemple). Ca voudrait dire qu'il faudrait que je les sélectionne 1 par 1...c'est pourquoi je pensais passer par un tableau....

Merci,
A+
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir erics83, nat54,

Dans le fichier joint je traite un tableau source de 9905 colonnes (colonne NPY) :
VB:
Sub Calcul()
Dim t, ncol%, P As Range, rc&, d As Object, dd As Object, i&, x$, j%, pos%, y$
t = Timer
'---analyse du tableau source---
ncol = 9905 'colonne NPY
Set P = Sheets("BD").UsedRange.Resize(, ncol)
rc = P.Rows.Count
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
For i = 2 To rc
    If i Mod 50 = 0 Then Application.StatusBar = Format((Timer - t) / 86400, "hh:mm:ss") & " - " & Int(100 * i / rc) & "%"
    x = P(i, 1) & P(i, 9)
    d(x) = d(x) + 1
    For j = 12 To ncol
        If P(1, j) <> "" Then
            pos = InStr(P(1, j), "/")
            If pos Then
                y = x & Chr(1) & Left(P(1, j), pos)
                If P(i, j) = 1 Then dd(y) = dd(y) + 1
            End If
        End If
Next j, i
'---restitution---
With Sheets("Résultat").[A1].CurrentRegion.Resize(, 12)
    For i = 2 To .Rows.Count
        x = .Cells(i, 1).MergeArea(1) & .Cells(i, 2)
        .Cells(i, 3) = d(x)
        For j = 4 To 12
            y = x & Chr(1) & .Cells(1, j) & "/"
            .Cells(i, j) = dd(y)
    Next j, i
End With
MsgBox "Calcul des résultats effectué en " & Format(Timer - t, "0.00 \sec")
End Sub
Chez moi il faut 11 minutes, le message dans la barre d'état permet de patienter...

Nota : un tableau VBA (matrice) 22461 x 9905 ne passe pas chez moi, ressources insuffisantes.

Je suis donc obligé de travailler sur les cellules, c'est moins rapide.

Edit : c'est mon 35000 ème post.

A+
 

Pièces jointes

  • Classeur Test(1).xlsm
    592.6 KB · Affichages: 5
Dernière édition:

erics83

XLDnaute Impliqué
Bonjour et merci Job75,

Merci car je vous félicite pour ce 35000ème post et oui car cela montre votre implication !!, vous m'avez déjà par le passé beaucoup aidé, donc merci.

Merci pour ce code qui fonctionne parfaitement, une fois de plus. Effectivement, la grandeur du tableau rend les calculs difficiles et ralentissent, mais l'essentiel soit que je puisse avoir les totaux...

Petite question : une fois que j'ai ces totaux, (et surtout qu'ils sont stockés dans dd()), est-il possible de faire une restitution par nomenclature : créer par exemple une feuille où ne seront que les nomenclature commençant par 1 et faire le total par nomenclature = faire le total de chaque colonnes. Puis ensuite trier les totaux du plus grand au plus petit ? Les 10 premiers totaux classés par ordre décroissants m'intéressent spécifiquement.

En vous remerciant par avance,
Eric
 

job75

XLDnaute Barbatruc
Bonjjour erics83, le forum,

Ah mais en utilisant les 2 tableaux VBA (matrices) titre et tablo c'est beaucoup plus rapide :
VB:
Sub Calcul()
Dim t, ncol%, P As Range, rc&, titre, j%, pos%, d As Object, dd As Object, i&, tablo, x$, y$
t = Timer
ncol = 9905 'colonne NPY
Set P = Sheets("BD").UsedRange.Resize(, ncol)
rc = P.Rows.Count
'---ligne de titres---
titre = P.Rows(1) 'matrice, plus rapide
For j = 12 To ncol
    If titre(1, j) <> "" Then
        pos = InStr(titre(1, j), "/")
        titre(1, j) = Left(titre(1, j), pos)
    End If
Next j
'---analyse du tableau source---
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
For i = 2 To rc
    If i Mod 50 = 0 Then Application.StatusBar = Format((Timer - t) / 86400, "hh:mm:ss") & " - " & Int(100 * i / rc) & "%"
    tablo = P.Rows(i) 'matrice, plus rapide
    x = tablo(1, 1) & tablo(1, 9)
    d(x) = d(x) + 1
    For j = 12 To ncol
        If titre(1, j) <> "" Then
            If tablo(1, j) = 1 Then
                y = x & Chr(1) & titre(1, j)
                dd(y) = dd(y) + 1
            End If
        End If
Next j, i
'---restitution---
With Sheets("Résultat").[A1].CurrentRegion.Resize(, 12)
    For i = 2 To .Rows.Count
        x = .Cells(i, 1).MergeArea(1) & .Cells(i, 2)
        .Cells(i, 3) = d(x)
        For j = 4 To 12
            y = x & Chr(1) & .Cells(1, j) & "/"
            .Cells(i, j) = dd(y)
    Next j, i
End With
MsgBox "Calcul des résultats effectué en " & Format(Timer - t, "0.00 \sec")
End Sub
Sur ce fichier (2) la macro s'exécute chez moi en 14 secondes.

Et avec la ligne 1 du tableau source remplie jusqu'en NPY1 l'exécution se fait en 32 secondes.

Pour ce qui est de votre nouvelle demande joignez un fichier montrant les résultats attendus.

A+
 

Pièces jointes

  • Classeur Test(2).xlsm
    593.1 KB · Affichages: 7

erics83

XLDnaute Impliqué
Bonjour et merci Job75,

Effectivement, c'est nettement plus rapide avec le même résultat ! SUPER !

Concernant ma demande, j'ai mis une feuille dans le classeur test pour "voir" le résultat attendu...je l'ai fait sous forme de TCD, histoire de voir la logique....

Merci pour votre aide,
 

Pièces jointes

  • Classeur test V3.xlsm
    798.6 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour erics83,

Bon je comprends que vous voulez simplement compter les items de chaque nomenclature.

Dans ce fichier (3) voici une solution avec 9 Dictionary :
VB:
Sub Classer()
Dim t, ncol%, P As Range, rc&, titre, titre1, j%, x$, pos%, i&, tablo
Dim d1 As Object, d2 As Object, d3 As Object, d4 As Object, d5 As Object, d6 As Object, d7 As Object, d8 As Object, d9 As Object
t = Timer
ncol = 9905 'colonne NPY
Set P = Sheets("BD").UsedRange.Resize(, ncol)
rc = P.Rows.Count
'---ligne de titres---
titre = P.Rows(1) 'matrice, plus rapide
titre1 = titre
For j = 12 To ncol
    x = titre(1, j)
    If x <> "" Then
        pos = InStr(x, "/")
        titre1(1, j) = Left(x, pos)
    End If
Next j
'---analyse du tableau source---
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")
Set d5 = CreateObject("Scripting.Dictionary")
Set d6 = CreateObject("Scripting.Dictionary")
Set d7 = CreateObject("Scripting.Dictionary")
Set d8 = CreateObject("Scripting.Dictionary")
Set d9 = CreateObject("Scripting.Dictionary")
For i = 2 To rc
    If i Mod 50 = 0 Then Application.StatusBar = Format((Timer - t) / 86400, "hh:mm:ss") & " - " & Int(100 * i / rc) & "%"
    tablo = P.Rows(i) 'matrice, plus rapide
    For j = 12 To ncol
        x = titre(1, j)
        If x <> "" Then
            If tablo(1, j) = 1 Then
                Select Case titre1(1, j)
                    Case "1/": d1(x) = d1(x) + 1
                    Case "2/": d2(x) = d2(x) + 1
                    Case "3/": d3(x) = d3(x) + 1
                    Case "4/": d4(x) = d4(x) + 1
                    Case "5/": d5(x) = d5(x) + 1
                    Case "6/": d6(x) = d6(x) + 1
                    Case "7/": d7(x) = d7(x) + 1
                    Case "8/": d8(x) = d8(x) + 1
                    Case "9/": d9(x) = d9(x) + 1
                End Select
            End If
        End If
Next j, i
'---restitution---
Application.ScreenUpdating = False
On Error Resume Next 'si un Dictionary est vide
With Sheets("Classement")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Rows("2:" & .Rows.Count).ClearContents 'RAZ
    For j = 2 To 26 Step 3
        Select Case 1 + (j - 2) / 3
            Case 1
                .Cells(2, j).Resize(d1.Count) = Application.Transpose(d1.keys) 'Transpose est limitée à 65536 lignes
                .Cells(2, j + 1).Resize(d1.Count) = Application.Transpose(d1.items)
                .Cells(2, j).Resize(d1.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo 'tri décroissant
            Case 2
                .Cells(2, j).Resize(d2.Count) = Application.Transpose(d2.keys)
                .Cells(2, j + 1).Resize(d2.Count) = Application.Transpose(d2.items)
                .Cells(2, j).Resize(d2.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 3
                .Cells(2, j).Resize(d3.Count) = Application.Transpose(d3.keys)
                .Cells(2, j + 1).Resize(d3.Count) = Application.Transpose(d3.items)
                .Cells(2, j).Resize(d3.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 4
                .Cells(2, j).Resize(d4.Count) = Application.Transpose(d4.keys)
                .Cells(2, j + 1).Resize(d4.Count) = Application.Transpose(d4.items)
                .Cells(2, j).Resize(d4.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 5
                .Cells(2, j).Resize(d5.Count) = Application.Transpose(d5.keys)
                .Cells(2, j + 1).Resize(d5.Count) = Application.Transpose(d5.items)
                .Cells(2, j).Resize(d5.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 6
                .Cells(2, j).Resize(d6.Count) = Application.Transpose(d6.keys)
                .Cells(2, j + 1).Resize(d6.Count) = Application.Transpose(d6.items)
                .Cells(2, j).Resize(d6.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 7
                .Cells(2, j).Resize(d7.Count) = Application.Transpose(d7.keys)
                .Cells(2, j + 1).Resize(d7.Count) = Application.Transpose(d7.items)
                .Cells(2, j).Resize(d7.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 8
                .Cells(2, j).Resize(d8.Count) = Application.Transpose(d8.keys)
                .Cells(2, j + 1).Resize(d8.Count) = Application.Transpose(d8.items)
                .Cells(2, j).Resize(d8.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
            Case 9
                .Cells(2, j).Resize(d9.Count) = Application.Transpose(d9.keys)
                .Cells(2, j + 1).Resize(d9.Count) = Application.Transpose(d9.items)
                .Cells(2, j).Resize(d9.Count, 2).Sort .Cells(2, j + 1), xlDescending, Header:=xlNo
        End Select
        .Columns.AutoFit 'ajustement largeurs
    Next j
End With
Application.ScreenUpdating = True
MsgBox "Classement effectué en " & Format(Timer - t, "0.00 \sec")
End Sub
La macro s'exécute chez moi en 26 secondes.

Avec la plage AL1:NPY1 remplie on passe à 30 secondes.

A+
 

Pièces jointes

  • Classeur test(3).xlsm
    603.7 KB · Affichages: 5

erics83

XLDnaute Impliqué
Bonjour Job75,

C'est extraordinaire 👍...exactement ce que je cherchais à obtenir !! Merci pour vos explications à l'intérieur du code qui me permettent de le "comprendre" et de pouvoir l'adapter....c'est simple et efficace !! et complètent mon apprentissage des "Dictionnary" (que j'avais commencé avec JB)

Super merci !

Encore merci pour tous vos apports et j'espère être un jour votre 40000 post...;)

A+ pour de prochaines aventures !
Merci Job75,
 

erics83

XLDnaute Impliqué
Re-bonjour Job75,

Les possibilités de votre code m'offrent de nouvelles perspectives et donc j'essaye de compiler différents fichiers et données.
En fait, j'ai 2 feuilles contenant les nomentlatures : la première contenant des nomentlatures jusqu'à la colonne NQE (9911), et une autre feuille avec des nomentlatures jusqu'à NLT (9796).
J'essaye de compiler (sans succès) les données de ces 2 feuilles, pour pourvoir faire les totaux....

J'ai essayé en faisant
VB:
'analyse com1
ncol = 9911 'colonne NQE
Set P1 = Sheets("BD1").UsedRange.Resize(, ncol)
rc = P1.Rows.Count
'---ligne de titres---
titre = P1.Rows(1) 'matrice, plus rapide
titre1 = titre
For j = 13 To ncol
    x = titre(1, j)
    If x <> "" Then
        pos = InStr(x, "/")
        titre1(1, j) = Left(x, pos)
    End If
Next j
'analyse com2
ncol = 9796 'colonne NLT
Set P2 = Sheets("BD2").UsedRange.Resize(, ncol)
rc = P2.Rows.Count
'---ligne de titres---
titr = P2.Rows(1) 'matrice, plus rapide
titr1 = titr
For j = 13 To ncol
    x = titr(1, j)
    If x <> "" Then
        pos = InStr(x, "/")
        titr1(1, j) = Left(x, pos)
    End If
Next j
Mais je n'arrive pas à "compiler"
Code:
Titre
et
Code:
Titr
afin d'avoir 1 seul tableau pour tous les titres et donc nomentlatures.....et naturellement, idem avec
Code:
Tblo
....pour pouvoir ensuite trouver/calculer sur les 19683 nomentlatures.....(9911-12 + 9796-12)

Merci pour votre aide et/ou éclairages....
 

Pièces jointes

  • Classeur test V5.xlsm
    635.9 KB · Affichages: 3
Dernière édition:

Discussions similaires

Réponses
9
Affichages
484

Statistiques des forums

Discussions
311 720
Messages
2 081 904
Membres
101 834
dernier inscrit
Jeremy06510