Dictionary pour remplacer TCD

erics83 · 21 Septembre 2016

Bonjour,

Grâce aux aides de JB et Job75 (merci !!!), j'ai pu lire très rapidement un tableau afin d'en extraire les données qui m'intéressent. (dans mon précédent post, c'était la recherche de doublons.)

Je souhaitais savoir s'il était possible d'utiliser Dictionary pour obtenir le même résultat qu'avec un TCD....

j'ai fait un essai :

Code:

Set d = CreateObject("Scripting.Dictionary")

With Feuil3
  Set P = .Range("A2", .Range("S" & .Rows.Count).End(xlUp)(19)) 'toutes les colonnes
End With
t = P


For j = 11 To Sheets("Totaux").Range("A65536").End(xlUp).Row - 2
totM = 0
tots = 0

For i = 1 To UBound(t)
 
  If ((t(i, 19)) = Sheets("Totaux").Cells(j, 1).Value And t(i, 18) = Sheets("Totaux").Cells(2, 1).Value And t(i, 17) = Sheets("Totaux").Cells(2, 2).Value And t(i, 16) = "Ac") Then ' Nom/Annee/mois/Ac
 
    totM = totM + t(i, 8)
    tots = tots + t(i, 8) + t(i, 9) + t(i, 10) + t(i, 11)
  
      End If
 
Next

Sheets("Totaux").Cells(j, 4) = totM
Sheets("Totaux").Cells(j, 5) = tots

Next

Il fonctionne, mais il est assez lent...et à force d'être impressionné par la rapidité de dictionary, je me dis qu'il y a peut-être une autre solution....???

En vous remerciant pour votre aide,

gosselien · 21 Septembre 2016

Bonjour,

sans fichier... pas facile

P.

Dranreb · 21 Septembre 2016

Bonjour
Évitez déjà les Sheets("Totaux").Cells(…
Un seul de chacun d'eux est pratiquement aussi long à exécuter qu'un TTot = Sheets("Totaux").UsedRange.Value effectué tout au début !

Dranreb · 21 Septembre 2016

Ensuite, oui, il y aurait probablement du travail pour ma fonction GroupOrg s'il s'agit de faire un récapitulatif classé de tout ce qui existe dans la liste détaillée de départ…
Le module qui la contient est même équipé d'une procédure PréFiltrer qui permettrait de faire en sorte qu'il ne prenne que les "Ac" et un certain mois.
En tout cas j'estime comme règle d'or de ne jamais travailler directement sur des cellules individuelles. Si en plus on évite les boucles imbriquées qui explorent la même chose c'est encore mieux.

erics83 · 21 Septembre 2016

Merci Dranreb,
je ne suis pas très calé sur le VBA, d'où ce type de Sheets("Totaux").Cells(…mais je n'ai pas compris comment je peux les remplacer pour gagner du temps ?

Merci gosselien, je n'osais pas mettre un fichier en début de post....je vous propose de prendre un fichier de JB pour l'exemple (naturellement le code mis précedement n'est pas en lien avec ce fichier) : je souhaite obtenir le même tableau que K2:N7, mais sans passer par TCD....

En vous remerciant pour votre aide,

Dranreb · 21 Septembre 2016

Remplacez les par des variables ou des éléments de tableaux contenant les valeurs.
Je livre la solution avec un GroupOrg.
Vous y verrez qu'on accède aux cellules une seule fois au début et une seule fois à la fin.

erics83 · 21 Septembre 2016

Whaou !!! Merci Dranreb,

et surtout merci pour toutes les explications dans le code c'est très sympa de votre part !!! Je vais étudier votre code de manière très précise car il y a beaucoup de choses/notions que je ne connais pas....et donc je vais essayer de comprendre...pourriez SVP m'envoyer ce même fichier en remplaçant dans le tableau obtenu le "service" par "statut", ainsi cela me permettra de voir où sont les changements, les impacts, etc....

(et c'est en consultant votre code, que je vois tous les progrès qu'il faut que j'accomplisse.... )

En vous remerciant

Dranreb · 21 Septembre 2016

Voilà.

erics83 · 21 Septembre 2016

Merci Dranreb,

je vais analyser le code et essayer de comprendre tout ce qui se passe....

14h17 : j'ai déjà fait 2-3 essais pour voir le comportement et comprendre tout ce qui se passe...j'ai réussi à mettre par age

Code:

For Each Statut In GroupOrg(ColUti(Feuil5.[A2:G2]), 5, 2)

, mais je n'arrive pas à modifier les colonnes "femmes et hommes", sauf en modifiant à partir de

Code:

If Sexe.Id = "Femme" Then C = 2 Else C = 3

naturellement....
par contre, y a t il un moyen de modifier en utilisant les chiffres (dans le "Statut in GroupOrg", en mettant 5, on a les ages, 3 le service, etc....puisque cela correspond au numéro de colonne.
pour être peut-être plus clair, admettons que je veuille obtenir la moyenne des salaires par service et par statut ....

Cadre | Employé | Maitrise | Secrétaire | Total général
Compta |
Etudes |
Fabrication |

.j'ai essayé en modifiant le "2" de Feuil5.[A2:G2]), 5, 2" pensant qu'il représentait la colonne 2 (=le sexe), mais le code se met en erreur...

Merci pour votre aide

Dranreb · 21 Septembre 2016

Ben c'est GroupOrg(ColUti(Feuil5.[A2:G2]), 3, 6)
Naturellement la boucle sur le dernier SsGroup doit être écrite autrement que pour le Sexe, puis qu'il y en a plus de 2,
Si on le veut aussi en colonnes, une fonction DicInvent du module MClassement sait fabriquer un dictionnaire des numéros de colonnes à consulter ensuite d'après les .Id correspondants.

erics83 · 21 Septembre 2016

Merci Dranreb,

j'avais essayé, mais le code se met en erreur "Dépassement de capacité" et bloque au niveau

Code:

L = L + 1: TS(L, 1) = "Total": For C = 2 To 4: TS(L, C) = TotG(C) / NbG(C): Next C

à "Next C"

Merci pour votre aide,

job75 · 21 Septembre 2016

Bonjour erics83, gosselien, Bernard,

Votre code prenait du temps erics83 parce que vous entriez les résultats un par un dans les cellules.

Et aussi parce que vous aviez des boucles imbriquées.

Voici ma solution :

Code:

Sub Test()

Dim NOM As Object, t, P As Range, anne%, mois, tt(), i&, j&

Set NOM = CreateObject("Scripting.Dictionary")
NOM.CompareMode = vbTextCompare 'la casse est ignorée

With Feuil3
    t = .Range("A2", .Range("S" & .Rows.Count).End(xlUp)(19)) 'toutes les colonnes mais pourquoi (19) ???
End With

With Sheets("Totaux")
    On Error Resume Next 'si P ne peut pas être défini
    Set P = .Range("A11:A" & .Range("A65536").End(xlUp).Row - 2)
    If P.Row < 11 Then Exit Sub 'sécurité
    On Error GoTo 0
    annee = .Cells(2, 1)
    mois = .Cells(2, 2)
End With

tt = P.Resize(, 2) 'au moins 2 éléments
For i = 1 To UBound(tt) 'liste des noms sans doublon et repérage de la ligne
    If tt(i, 1) <> "" Then NOM(tt(i, 1)) = i
Next

ReDim tt(1 To P.Rows.Count, 1 To 2)
For i = 1 To UBound(t)
    If NOM.exists(t(i, 19)) Then
        If t(i, 18) = annee And t(i, 17) = mois And t(i, 16) = "Ac" Then
            j = NOM(t(i, 19)) 'récupération de la ligne
            tt(j, 1) = tt(j, 1) + t(i, 8)
            tt(j, 2) = tt(j, 2) + t(i, 8) + t(i, 9) + t(i, 10) + t(i, 11)
        End If
    End If
Next

P.Columns(4).Resize(, 2) = tt 'restitution

End Sub

Question : pourquoi (19) sur le .End(xlUp)(19) ? (2) j'aurais compris...

A+

Dranreb · 21 Septembre 2016

Réécrivez complètement la boucle interne. NbG est il convenablement dimensionné ? Que valent C et NbG(C) ?

job75 · 21 Septembre 2016

Re,

J'ai ajouté On Error Resume Next pour sortir quand P ne peut être défini (colonne vide par exemple).

Edit : on pourrait mettre cette instruction au tout début mais il vaut mieux laisser la macro beuguer si Feuil3 ou Sheets("Totaux") n'existent pas...

A+

Dranreb · 21 Septembre 2016

VB:

Sub ParServiceEtStatut()
Dim Données As Range, DCol As Dictionary, TS(), CFin As Long, L As Long, C As Long, Détail, _
  Service As SsGroup, TotSrv As Double, Statut As SsGroup, Tot As Double, NbSrv As Long
Set Données = ColUti(Feuil5.[A2:G2])
Set DCol = DicInvent(Données, 6, ColDép:=2): CFin = DCol.Count + 2
ReDim TS(1 To 500, 1 To 20), TotG(2 To 20), NbG(2 To 20)
L = 1
C = 1: TS(1, C) = "Service"
For Each Détail In DCol.Keys: C = C + 1: TS(1, C) = Détail: Next Détail
C = C + 1: TS(1, C) = "Total"
For Each Service In GroupOrg(Données, 3, 6)
  L = L + 1
  TS(L, 1) = Service.Id
  TotSrv = 0: NbSrv = 0
  For Each Statut In Service.Contenu
     C = DCol(Statut.Id)
     Tot = 0
     For Each Détail In Statut.Contenu
        Tot = Tot + Détail(7): Next Détail
     TS(L, C) = Tot / Statut.Count
     TotSrv = TotSrv + Tot: NbSrv = NbSrv + Statut.Count
     TotG(C) = TotG(C) + Tot: TotG(CFin) = TotG(CFin) + Tot
     NbG(C) = NbG(C) + Statut.Count: NbG(CFin) = NbG(CFin) + Statut.Count
     Next Statut
  TS(L, CFin) = TotSrv / NbSrv: Next Service
L = L + 1: TS(L, 1) = "Total"
For C = 2 To CFin
  If NbG(C) <> 0 Then TS(L, C) = TotG(C) / NbG(C)
  Next C
Feuil5.[J12].Resize(500, 20).Value = TS
End Sub

Cochez la référence "Microsoft Scripting Runtime", et dans MClassement, 'décomentairisez' la #Const MSRCochée = 1 ' La Référence "Microsoft Scripting Runtime" est cochée.

Dictionary pour remplacer TCD

erics83

XLDnaute Impliqué

gosselien

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

Pièces jointes

Dranreb

XLDnaute Barbatruc

Pièces jointes

erics83

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

Pièces jointes

erics83

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Pièces jointes

Discussions similaires