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,

erics83 · 21 Septembre 2016

Merci Dranreb,

C=2 et Nbg(C)=0....et j'ai copié/collé votre code et j'ai toujours "dépassement de capacité"...?
edit : nos post se sont croisés....génial !!! tout fonctionne parfaitement !!! Merci !!! . j'ai édité tous les modules et vais me pencher dessus pour essayer de comprendre la logique du code, car il me semble compliqué (à première vue), mais la logique est implacable puisqu'il fonctionne parfaitement !!! donc je vais analyser le cheminement et essayer de comprendre et ré-utiliser...

Merci job75,

"pourquoi (19) ?" : je pensais que cela représentait les 19 colonnes de mon tableau....vous me dites que 2, c'est OK, mais donc à quoi cela correspond-t-il exactement ? Je pensemble que ce sont des dimensions, mais cela correspond à qoui exactement ? C'est comme si on avait un tableau avec 2 colonnes ?

Sinon, j'ai testé votre code et....j'en était sur....c'est très rapide..... j'avais aussi mis un non-rafraîchisseur d'écran pour éviter la lenteur dans l'inscription dans chaque case...mais cela ne suffisait pas....vive votre code !!!

Je souhaite vraiment renforcer mes connaissance dans le dictionary, et essayer de connaitre les différents codes (exists, etc...), vous n'auriez pas un "bon" lien vers un "bon" tuto ?

Merci beaucoup pour ce code que je vais m'empresser d'exploiter....car maintenant, ce que j'aimerai faire, c'est que lorsque je clique sur la case où un résultat s'affiche (je vais utiliser le doubleclic et target), j'affiche un userform (ou autre) avec les lignes qui ont amené ce résultat et prendre les éléments....un peu comme lorsqu'on clique dans une valeur dans un TCD, une feuille s'affiche avec les données....

En vous remerciant par avance,

job75 · 21 Septembre 2016

Re,

.End(xlUp) qu'on pourrait aussi écrire .End(xlUp)(1) donne la dernière cellule non vide de la colonne.

.End(xlUp)(2) donne la cellule (vide) juste en-dessous.

A+

erics83 · 21 Septembre 2016

Merci job75,

Une fois de plus, je cherchais la complication alors que c'était tout simple....mais comme on était dans les tableaux, je pensais que c'était lié.....

Là je suis sur mon projet (affichage des lignes lors du doubleclic), je galère un peu (beaucoup), mais je m'accroche....

edit : mais j'ai un soucis : rien ne s'affiche dans Feuil1 et je ne comprends pas pourquoi.....

Code:

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Dim NOM As Object, t, P As Range, anne%, mois, tt(), i&, j&

If Target.Column = 4 Then

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

With Feuil3
  t = .Range("A2", .Range("S" & .Rows.Count).End(xlUp)(1))
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
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(target.row, 19)) 'récupération de la ligne
  tt(j, 1) = t(i, 4)
  tt(j, 2) = t(i, 3)
  End If
  End If
Next

Sheets("Feuil1").Select 'affichera dans Feuil1 pour USF : à l'ouverture du USF, recherchera les données inscrites dans Feuil1
P.Columns(1).Resize(, 2) = tt 'restitution


End If

End Sub

edit : j'ai essayé de mettre "P.Columns(1).Resize(, 20) = tt 'restitution" et j'ai des valeurs en colonne 20, mais elles ne correspondent pas au nom et s'affichent dans "Totaux"....et surtout ce ne sont qu'une seule ligne....????

Merci pour votre aide,
A+

erics83 · 21 Septembre 2016

Re,

En fait, apparemment, le problème vient que le code n'arrive pas à "retrouver" le NOM....et donc ne fait pas une recherche en fonction du NOM....pour afficher en Feuil1, j'ai fait :

Code:

 j = NOM(t(Target.Row, 19)) + 1 'récupération de la ligne
          
            a = a + 1
           Sheets("Feuil1").Cells(a, 1) = t(i, 4)
           Sheets("Feuil1").Cells(a, 2) = t(i, 3)

pas très orthodoxe, mais qui m'a permis de voir que mon code ne fait pas le lien avec le NOM : lorsque je doubleclic, j'arrive bien à récupérer le numéro de la ligne, mais je n'arrive pas à le récupérer pour qu'il corresponde avec NOM.....

Une petite aide ?

En vous remerciant,

erics83 · 21 Septembre 2016

re,

C'est bon, j'ai trouvé.....le code n'est vraiment pas orthodoxe, mais...il fonctionne (pour le moment...), enfin, avec la colonne 4.....car il va falloir que je fasse pour toutes les colonnes de mon tableaux "Totaux"....ça va, 20 colonnes, ça peut être gérable....

Code:

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Dim NOM As Object, t, P As Range, anne%, mois, tt(), i&, j&, tu()

If Target.Column = 4 Then


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

With Feuil3
    t = .Range("A2", .Range("S" & .Rows.Count).End(xlUp)(2))
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
tu = P
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
    If tu(i, 1) <> "" Then NOM(tu(i, 1)) = i
Next

ReDim tt(1 To P.Rows.Count, 1 To 2)
For i = 1 To UBound(t)

    If (t(i, 19)) = tu(Target.Row - 10, 1) 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
            a = a + 1
            Sheets("Feuil1").Cells(a, 1) = t(i, 4)
            Sheets("Feuil1").Cells(a, 2) = t(i, 3)
            Sheets("Feuil1").Cells(a, 3) = t(i, 8)
            '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 If

End Sub

en Feuil1 la liste s'affiche et donc à l'ouverture du USF, elle sera "rapatriée"....

J'avais bloqué sur NOM, alors qu'il fallait regarder du côté de "tt", enfin "tu" puisque "tt" est redimensionné (ce qui m'a pris du temps, acr je ne comprenanis pas pourquoi je ne retrouvais pas les noms...donc, solution palliative...

Donc, si vous avez une meilleure formulation de ce code, suis preneur....cela me permettra d'apprendre un peu plus sur VBA....

En vous remerciant pour votre aide,

job75 · 22 Septembre 2016

Bonjour erics83, le forum,

Vous faites vraiment n'importe quoi, ce n'est pas parce qu'on vous donne une macro pour un problème précis qu'il faut la mettre à toutes les sauces.

Dans votre dernier code vous voyez bien que le Dictionary ne sert plus à rien et vous recommencez vos errements en traitant les cellules une par une avec Sheets("Feuil1").Cells(...

Cette histoire de double-clic n'a plus rien à voir avec le problème initial, je vous conseille d'ouvrir une nouvelle discussion en joignant un fichier (allégé mais significatif) et en indiquant où vous voulez faire le double-clic et quels résultats vous voulez obtenir.

Bonne journée.

job75 · 22 Septembre 2016

Re,

Bon, pour vous éviter d'ouvrir un nouveau fil et en supposant que :

- le double-clic se fait en colonne D de la feuille "Totaux"

- vous voulez restituer les résultats de la recherche dans une ListBox de l'UserForm :

Code:

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim P As Range, nom$, annee%, mois, t, i&, n&, tt()

On Error Resume Next 'si P ne peut pas être défini
Set P = Range("D11:D" & Range("A" & Rows.Count).End(xlUp).Row - 2)
If P.Row < 11 Or Intersect(Target, P) Is Nothing Then Exit Sub
On Error GoTo 0
Cancel = True
nom = Cells(Target.Row, 1)
annee = [A2]
mois = [B2]

With Feuil3
    t = .Range("A2", .Range("S" & .Rows.Count).End(xlUp)(2))
End With

For i = 1 To UBound(t)
    If t(i, 19) = nom And t(i, 18) = annee And t(i, 17) = mois And t(i, 16) = "Ac" Then
        n = n + 1
        ReDim Preserve tt(1 To 3, 1 To n)
        tt(1, n) = t(i, 4)
        tt(2, n) = t(i, 3)
        tt(3, n) = t(i, 8)
    End If
Next

If n Then
    With UserForm1.ListBox1 'adapter si nécessaire
        If n = 1 Then
            .AddItem tt(1, 1)
            .List(0, 1) = tt(2, 1)
            .List(0, 2) = tt(3, 1)
        Else
            .List = Application.Transpose(tt)
        End If
        .Parent.Show
    End With
Else
    MsgBox "Pas de ligne correspondante en feuillle '" & Feuil3.Name & "'..."
End If

End Sub

Une restitution en "Feuil1" est a priori inutile.

A+

erics83 · 22 Septembre 2016

Merci job75,
et surtout merci pour votre franchise...c'est vrai que bidouiller un code, comporte beaucoup de risques...et d'incohérences....

Donc, je suis votre conseil et mets en PJ le fichier test. J'ai volontairement enlevé toutes les macros, car à force de faire des essais, je risquais d'avoir laissé des codes "trafiqués" qui auraient pu poser problème....

J'ai mis dans la feuille "Totaux" tous les commentaires, notamment des formules de calculs (les commentaires se trouvent essentiellement dans les lignes 8 , et quelqu'uns dans les lignes 1,2,3,4,5.
En feuille ("Totaux affichage"), j'ai mis le résultat attendu lorsque je doubleclic sur une cellule. (=affichage USF)

Et j'ai mis dans les feuilles "Toutes réservations" et "Réservations finies" identifié en rouge les colonnes où je rajoute des formules (=les colonnes signalées en jaune correspondent à mon extraction de données), je suis passé par des formules, mais avec dictionary, je pense que l'on peut s'en passer....mais dans le doute....

Je vous remercie très sincèrement pour toute l'aide que vous m'apportez,
Merci,

job75 · 23 Septembre 2016

Bonjour erics83, le forum,

Sur votre dernier fichier je ne me suis occupé que du double-clic dans la feuille "Totaux".

Je suis sûr que vous pouviez adapter tout seul ma macro du post #22, c'eût été un bon exercice.

J'ai supprimé le test avec "Ac", s'il faut mettre autre chose à la place dites-le.

Fichier joint.

Bonne journée.

erics83 · 23 Septembre 2016

Bonjour et merci job75,

Oui, je remplirai les formules, grâce à votre précédent code, j'ai tous les éléments pour pouvoir le faire, mais comme vous m'aviez suggérer de donner tous les éléments, j'ai préféré mettre les formules dans les commentaires. Je l'avais mis dans les échanges, mais je viens de voir que ma mise à jour (edition) du message ne s'est pas réalisée....

J'ai apporté une petite modification dans votre code :

Code:

n = 1
For i = 1 To UBound(t)
    If LCase(t(i, 18)) = nom And t(i, 17) = annee And t(i, 16) = mois Then
        If t(i, 8) > 0 Then n = n + 1
        ReDim Preserve tt(1 To 3, 1 To n)
        If t(i, 8) > 0 Then tt(1, n) = t(i, 3)
       
        If t(i, 8) > 0 Then tt(2, n) = t(i, 4)
        If t(i, 8) > 0 Then tt(3, n) = t(i, 8)
    End If
Next

car en fait (et j'avais oublié de le préciser) dans l'USF, je ne souhaite "voir" que les "nombres de réservations" supérieures à 1, donc j'ai rajouté cet élément "t(i,8)>0"

Par contre, pour revenir aux formules, vous avez remarqué que j'ai 2 fichiers sources "Réservation finies" et "Toutes réservations" et que dans mon tableau dans "Totaux", je fais des calculs à la fois à partir de "Réservations finies" (colonnes D,E,F,G,J,K) et d'autres à partir de "Toutes réservations".(colonnes I,M,N,O,P,Q,R,S,T,U)
Apparemment il faudrait que je crée 2 dictionary .... mais je crains de faire la même erreur que précédemment.....

Comment procéder ?

En vous remerciant pour votre aide,

job75 · 23 Septembre 2016

Re,

Si l'on veut lister uniquement les réservations dont le nombre est > 0 il suffit d'un seul test t(i, 8) > 0.

On voit qu'en D11 (cas "Non identifié") il devrait y avoir un 1...

Par ailleurs pour n = 1 (cas de "Pascale") j'ai ajouté .Clear pour RAZ de la ListBox.

Fichier (2).

Pour la dernière question je ne vois pas ce que vous voulez dire par "pour revenir aux formules".

De toute façon si vous voulez traiter 2 feuilles sources c'est simple : il faut 2 macros...

A+

job75 · 23 Septembre 2016

Re,

J'ai aussi introduit la variable entete dans le fichier (2).

A+

erics83 · 23 Septembre 2016

Merci job75, oui, j'ai vu pour l'entete dans le fichier, effectivement très pratique.

"pour revenir aux formules", c'était juste parce que je changeais de sujet. Donc, ok, je fais 2 macros (que je reprends de votre post #22) 1 pour "Toutes réservations et 1 pour "réservation finies", mais concernant le doubleclick, cela veut dire quand dans le code de la feuil3 (="Totaux"), je mets 2 macros doubleclick ?

Concernant les formules, pour calcule E12 (par exemple), je vais mettre la formule

Code:

tt(4, n) = t(i, 8) + t(i,9)+t(i,10)+t(i,11)

mais pour que le doubleclick fonctionne il va falloir que je mette

Code:

if target.column = 5 then

et

Code:

ReDim Preserve tt(1 To 4, 1 To n)
        tt(1, n) = t(i, 3)
        tt(2, n) = t(i, 4)
        tt(3, n) = t(i, 8)
        tt(4, n) = t(i, 8) + t(i,9)+t(i,10)+t(i,11)

c'est bien ça ?

En vous remerciant pour votre aide,

job75 · 23 Septembre 2016

Re,

J'ai regardé les commentaires et je comprends que vous voulez un traitement particulier pour chaque colonne.

Votre projet est peut-être faisable en construisant une usine à gaz.

Alors je vous laisse continuer tout seul, désolé.

A+

erics83 · 23 Septembre 2016

Bonjour Job75,

Une fois de plus, merci pour votre franchise......
oui, en fait, chaque colonne a un calcul différent...:

Code:

Réservations finies    Colonne D     t(i,8)>0
Réservations finies    Colonne E    t(i,8)+(t(i,9)+t(i,10)+t(i,11)
Réservations finies    Colonne F    t(i,8)/(t(i,8)+(t(i,9)+t(i,10)+t(i,11))
Réservations finies    Colonne G     t(i,8)/(t(i,8)+t(i,9))
Toutes réservations    Colonne I     u(j,19)>1
Réservations finies    Colonne J    t(i,9)
Réservations finies    Colonne K     t(i,10)+t(i,11)
Toutes réservations    Colonne M     u(j,16)
Toutes réservations    Colonne N     si u(j,5)<now
Toutes réservations    Colonne O     si u(j,18)="Pension complète"
Toutes réservations    Colonne P    si u(j,18)="Demi pension"
Toutes réservations    Colonne Q    si u(j,18)="Pension complète"/(si u(j,18)="Pension complète"+si u(j,18)="Demi pension")
Toutes réservations    Colonne R    si u(j,11)<>"ANNULEE"
Toutes réservations    Colonne S    si u(j,17)="OUI"
Toutes réservations    Colonne T    si u(j,12)= "Non suivie"
Toutes réservations    Colonne U    si u(j,10)>30

J'ai essayé en mettant des conditions en fonction de la colonne sélectionnée (dans l'exemple, j'ai juste mis la colonne 4 et 5) : si clic sur colonne 5 then....etc.....

Code:

Option Explicit

Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim P As Range, NOM$, annee%, mois, t, entete$, i&, n&, tt()

If Target.Column = 4 Then
On Error Resume Next 'si P ne peut pas être défini
Set P = Rows("11:" & Range("A" & Rows.Count).End(xlUp).Row - 2)
If P.Row < 11 Or Intersect(Target, P) Is Nothing Then Exit Sub
On Error GoTo 0
Cancel = True
NOM = LCase(Cells(Target.Row, 1))
annee = [A2]
mois = [B2]

With Feuil6
    t = .Range("A2", .Range("R" & .Rows.Count).End(xlUp)(2))
    entete = .Name & " : " & Application.Proper(NOM)
End With

For i = 1 To UBound(t)
    If LCase(t(i, 18)) = NOM And t(i, 17) = annee And t(i, 16) = mois And t(i, 8) > 0 Then
        n = n + 1
        ReDim Preserve tt(1 To 3, 1 To n)
        tt(1, n) = t(i, 3)
        tt(2, n) = t(i, 4)
        tt(3, n) = t(i, 8)
    End If
Next

If n Then
    With UserForm1.ListBox1 'adapter si nécessaire
        If n = 1 Then
            .Clear 'RAZ
            .AddItem tt(1, 1)
            .List(0, 1) = tt(2, 1)
            .List(0, 2) = tt(3, 1)
        Else
            .List = Application.Transpose(tt)
        End If
        .Parent.Caption = entete
        .Parent.Show 0 'non modal
    End With
Else
    MsgBox "Aucune réservation...", , entete
End If

End If


If Target.Column = 5 Then
On Error Resume Next 'si P ne peut pas être défini
Set P = Rows("11:" & Range("A" & Rows.Count).End(xlUp).Row - 2)
If P.Row < 11 Or Intersect(Target, P) Is Nothing Then Exit Sub
On Error GoTo 0
Cancel = True
NOM = LCase(Cells(Target.Row, 1))
annee = [A2]
mois = [B2]

With Feuil6
    t = .Range("A2", .Range("R" & .Rows.Count).End(xlUp)(2))
    entete = .Name & " : " & Application.Proper(NOM)
End With

For i = 1 To UBound(t)
    If LCase(t(i, 18)) = NOM And t(i, 17) = annee And t(i, 16) = mois And t(i, 15) = "Pension complète" Then
        n = n + 1
        ReDim Preserve tt(1 To 3, 1 To n)
        tt(1, n) = t(i, 3)
        tt(2, n) = t(i, 4)
        tt(3, n) = t(i, 8) + t(i, 9) + t(i, 10) + t(i, 11)
    End If
Next

If n Then
    With UserForm1.ListBox1 'adapter si nécessaire
        If n = 1 Then
            .Clear 'RAZ
            .AddItem tt(1, 1)
            .List(0, 1) = tt(2, 1)
            .List(0, 2) = tt(3, 1)
        Else
            .List = Application.Transpose(tt)
        End If
        .Parent.Caption = entete
        .Parent.Show 0 'non modal
    End With
Else
    MsgBox "Aucune réservation...", , entete
End If
End If

End Sub

J'imagine que c'est cela que vous appelez "usine à gaz", j'en conclu qu'apparemment il n'y a pas d'autres solutions...je pensais que l'on pouvait mettre les formules des calculs des colonnes en stockage et les "appeler" en cas....

Dernière petite question si vous le voulez bien : étant donné que je vais d'abord faire tous les calculs (via votre code "Test", merci ), on ne peut pas les "stocker" ? Mon premier réflexe serait de les mettre dans une feuille , mais vous m'avez démontré que l'on peut les stocker dans "tt" par exemple...
Donc je lance le code "Test", on garde en mémoire les données dans tt(i,......et on les rapatrie lorsqu'on ira sur "Totaux" et lors du doubleclick on les rappelle....

En vous remerciant pour votre aide,

Dictionary pour remplacer TCD

erics83

XLDnaute Impliqué

erics83

XLDnaute Impliqué

job75

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

erics83

XLDnaute Impliqué

erics83

XLDnaute Impliqué

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

erics83

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

job75

XLDnaute Barbatruc

erics83

XLDnaute Impliqué

Discussions similaires