sous total base de données objet doctionary

[Pierrot75]

bonjour à tous,

ci-joint un fichier téléchargé sur un site très recommandable qui permet de calculer des sous-totaux de base de données en utilisant l'objet dictionnary pour accélerer le code.

Cela me conviendrait très bien à quelque chose près:
les colonnes orange sont celles que je ne souhaite pas conserver après l'éxécution de la macro
la colonne jaune est à conserver car c'est sur ces données qu'est effectué une recherché de doubloon puis le sous total.
les sous totaux sont faits sur les valeurs numériques des colonnes Refx et Qx.


Merci d'avance de votre coup de main.

 

[job75]

Re : sous total base de données objet doctionary

Bonjour Pierrot75,

ci-joint un fichier téléchargé sur un site très recommandable

Sans doute mais le code était assez maladroit : quand on le peut il faut éviter Application.Match dans les boucles, il ralentit beaucoup l'exécution.

Donc avec une utilisation plus habile du "Dictionary" :

Sub SousTotal2()
Dim a, ncol%, rest(), d As Object, i&, n&, lig&, j%
a = Range("B2:AB" & [A65000].End(xlUp).Row)
ncol = UBound(a, 2)
ReDim rest(1 To UBound(a), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a)
  If Not d.exists(a(i, 1)) Then _
    n = n + 1: d(a(i, 1)) = n: rest(n, 1) = a(i, 1)
  lig = d(a(i, 1))
  For j = 4 To ncol
    rest(lig, j) = rest(lig, j) + a(i, j)
  Next
Next
[AD1].Resize(, ncol) = [B1].Resize(, ncol).Value 'en-têtes
[AD2].Resize(n, ncol) = rest
[AD2].Resize(n, ncol).Borders.Weight = xlHairline 'bordures
[AD2].Offset(n).Resize(Rows.Count - n - 1, ncol).Delete xlUp
[AD:AD].Resize(, ncol).Columns.AutoFit
[AE:AF].Delete 'colonnes inutiles
End Sub

Fichier joint.

A+

 

[Compte Supprimé 979]

Re : sous total base de données objet doctionary

Bonjour le fil,

Moi je veux bien les gars, sauf qu'il y'a une c*uille dans le paté comme on dit
Q1 à Q5 = 0 sur toutes les lignes, comment un sous-total peut faire >0 ??

A+

 

[Pierrot75]

Re : sous total base de données objet doctionary

rebonjour, merci beaucoup de vos réponses.
entre temps, j'ai la solution qui me convenait qui se rapproche beaucoup du fichier envoyé initialement.
voice ce que cela donne au final en utilisant ce bout de code dans une fonction suivant le nom de l'onglet traité et la colonne de reference.

Merci encore.

 

[job75]

Re : sous total base de données objet doctionary

Re, salut Bruno,

Moi je veux bien les gars, sauf qu'il y'a une c*uille dans le paté comme on dit
Q1 à Q5 = 0 sur toutes les lignes, comment un sous-total peut faire >0 ??

Le manque de curiosité est un vilain défaut, il suffit d'élargir les colonnes Qx pour voir qu'elles ne sont pas nulles.

C'est ce que j'ai fait dans mon fichier.

Maintenant voici une meilleure solution :

Sub SousTotal2()
Dim a, ncol%, rest(), d As Object, i&, n&, lig&, j%
a = Range("B2:AB" & [A65000].End(xlUp).Row)
ncol = UBound(a, 2) - 2
ReDim rest(1 To UBound(a), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a)
  If Not d.exists(a(i, 1)) Then _
    n = n + 1: d(a(i, 1)) = n: rest(n, 1) = a(i, 1)
  lig = d(a(i, 1))
  For j = 2 To ncol
    rest(lig, j) = rest(lig, j) + a(i, j + 2)
  Next
Next
[AD2].Resize(n, ncol) = rest
[AD2].Resize(n, ncol).Borders.Weight = xlHairline 'bordures
[AD2].Offset(n).Resize(Rows.Count - n - 1, ncol).Delete xlUp
End Sub

Elle évite de traiter la ligne 1 et de supprimer les 2 colonnes inutiles.

Le tableau peut être formaté une fois pour toutes.

Fichier (2).

A+

 

[Compte Supprimé 979]

Re : sous total base de données objet doctionary

Salut Jo75

Re, salut Bruno,
Le manque de curiosité est un vilain défaut

Tout comme le manque de mise en forme de ses tableaux...
Tu me connaîtrais mieux tu ne dirais pas ce genre de connerie, je n'ai pas ce genre de défaut et je ne faisais que passer

il suffit d'élargir les colonnes Qx pour voir qu'elles ne sont pas nulles.

Effectivement