probleme avec nombre d'elements dans un dictionnaire

**lps02** · 31/05/2012, 19h32

Bonsoir le forum

voilà mon soucis. j'ai créé le code suivant qui marche super bien lorsque j'ai plus d'un element dans la liste de mon dictionnaire;
par contre lorsque je n'ai qu'un élément, ça ne fonctionne pas.Je voudrais quand même que l'élément se mette en AE3.

Pouvez vous m'aider?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Private Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range
 
 
 'pour les essences
Set MonDico = CreateObject("Scripting.Dictionary")
 
With Worksheets("lotissement")
    For Each c In .Range("A12:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(Trim(c.Value)) Then MonDico.Add Trim(c.Value), Trim(c.Value)
    Next c
 
 
 
    With .Range("AE3").Resize(MonDico.Count, 1)
        .Value = Application.Transpose(MonDico.keys)
        .Sort Key1:=Worksheets("lotissement").Range("AE3"), Order1:=xlAscending, Header:=xlNo
    End With
 
End With
Set MonDico = Nothing
' Calcul du volume selon essence et qualite
Dim i As Long, LigFin As Long
Dim fct As String, fct1 As String, fct2 As String, fct3 As String, fct4 As String
 
LigFin = [AE65536].End(xlUp).Row
 
For i = 3 To LigFin
    fct = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AF$2))"
    fct1 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AG$2))"
    fct2 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AH$2))"
    fct3 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AI$2))"
    fct4 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AJ$2))"
    Cells(i, 32) = Evaluate(fct)
    Cells(i, 33) = Evaluate(fct1)
    Cells(i, 34) = Evaluate(fct2)
    Cells(i, 35) = Evaluate(fct3)
    Cells(i, 36) = Evaluate(fct4)
    Range("AK" & i) = Application.WorksheetFunction.Sum(Range("AF" & i), Range("AG" & i), Range("AH" & i), Range("AI" & i), Range("AJ" & i))
 
Next i
 
Call tri_qualite
 
End Sub

**lps02** · 31/05/2012, 20h44

Rebonsoir le forum

Je me suis penche à nouveau sur mon code et il se trouve qu'il ne fonctionne pas quand il y a plusieurs lignes dans le dictionnaire "Propriétaire".
Quand il n'y en a qu'un suel, tout marche mais des qu'il y en a deux, ça ne marche pas (aucun message d'erreur par contre).
J'ai essyé de modifier l'ordre d'appel des procedures dans la procedure principale mais rien n'y fait.

Avez vous une solution???
Je bloque là dessus depuis ce matin

Cordialement
lps02

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Private Sub SansDoublonsTrie()
Dim MonDico As Object
Dim c As Range
 
 
 'pour les essences
Set MonDico = CreateObject("Scripting.Dictionary")
 
With Worksheets("lotissement")
    For Each c In .Range("A12:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not MonDico.exists(Trim(c.Value)) Then MonDico.Add Trim(c.Value), Trim(c.Value)
    Next c
 
 
 
    With .Range("AE3").Resize(MonDico.Count, 1)
        .Value = Application.Transpose(MonDico.keys)
        .Sort Key1:=Worksheets("lotissement").Range("AE3"), Order1:=xlAscending, Header:=xlNo
    End With
 
End With
Set MonDico = Nothing
' Calcul du volume selon essence et qualite
Dim i As Long, LigFin As Long
Dim fct As String, fct1 As String, fct2 As String, fct3 As String, fct4 As String
 
LigFin = [AE65536].End(xlUp).Row
 
For i = 3 To LigFin
    fct = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AF$2))"
    fct1 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AG$2))"
    fct2 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AH$2))"
    fct3 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AI$2))"
    fct4 = "=SUMPRODUCT($K$12:$K$2000*(($A$12:$A$2000)=" & Range("AE" & i).Address(False, True) & ")*(($G$12:$G$2000)=AJ$2))"
    Cells(i, 32) = Evaluate(fct)
    Cells(i, 33) = Evaluate(fct1)
    Cells(i, 34) = Evaluate(fct2)
    Cells(i, 35) = Evaluate(fct3)
    Cells(i, 36) = Evaluate(fct4)
    Range("AK" & i) = Application.WorksheetFunction.Sum(Range("AF" & i), Range("AG" & i), Range("AH" & i), Range("AI" & i), Range("AJ" & i))
 
Next i
 
Call tri_qualite
 
End Sub
 
Private Sub Propriétaire()
Dim Dico As Object
Dim j As Range
Dim d As Variant
Dim b As Long
'tri sur les proprietaire sans doublons par ordre alpha
Set Dico = CreateObject("Scripting.Dictionary")
With Worksheets("lotissement")
    For Each j In .Range("N12:N" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If Not Dico.exists(Trim(j.Value)) Then Dico.Add Trim(j.Value), Trim(j.Value)
    Next j
    temp = Dico.items
 Call Tri(temp, LBound(temp), UBound(temp)) ' voir module mod_tri
 
     b = 3
        For Each d In temp
        .Cells(4, b) = d  'pour recopier la liste des éléments uniques à partir de la cellule C4
        b = b + 1
        Next d
 
    .Cells(3, 21).Value = Application.WorksheetFunction.Proper(Join(temp, "-")) 'pour regrouper les apporteurs en cellules U3
 
 
End With
   Set Dico = Nothing
 
End Sub
 
Sub Tri(j, gauc, droi)   ' Quick sort
 ref = j((gauc + droi) \ 2)
 G = gauc: d = droi
 Do
  Do While j(G) < ref: G = G + 1: Loop
  Do While ref < j(d): d = d - 1: Loop
  If G <= d Then
  temp = j(G): j(G) = j(d): j(d) = temp
  G = G + 1: d = d - 1
  End If
 Loop While G <= d
 If G < droi Then Call Tri(j, G, droi)
 If gauc < d Then Call Tri(j, gauc, d)
 End Sub

**lps02** · 31/05/2012, 21h21

J'ai trouve

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

.Sort Key1:=Worksheets("lotissement").Range("AE3"), Order1:=xlAscending, Header:=xlNo

Comme il y a des entetes il fallait mettre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

.Sort Key1:=Worksheets("lotissement").Range("AE3"), Order1:=xlAscending, Header:=xlYes

Bonne soirée à vous
Cordialement
lps02

probleme avec nombre d'elements dans un dictionnaire

Macros et VBA Excel

Discussions similaires

Partager

Partager