Correction d’un code

Version imprimable

Bonsoir à tous,

Pour cette première phase de comptage, j’ai en colonne A, des chiffres triés, allant de 0 à 12000.

En colonne I, j’ai un tableau d’intitulés, et en colonne J les ensembles affectées à ces intitulés.

Intitulé Ensemble
TT [0-5]
TT [6-8]
ZYR [9-15]
SRG [16-21]
SRG [30-52]
FDR [22-25]

Les ensembles sont sous forme de [x-y] (Commence à x et se termine par y).

Alors en colonne C, j’aimerais mettre seulement les ensembles qui ont leurs valeurs dans la colonne A.

En colonne D, le total des valeurs trouvées de chaque ensemble dans la colonne A.

Par exemple :

En colonne A :
0
1
2
3
4
5
6
7
8
9
10
11

En colonne C (Ensemble) et D (Total), on devra avoir :

Ensemble Total
[0-5] 6
[6-9] 4
[10-25] 2

Mais voila le code suivant, compte bien ces totaux, mais ne les affiche pas dans la colonne D.

Code:

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
Sub CompteOccu()
    Dim dl As Long    'déclare la variable dl (Dernière Ligne)
    Dim pl As Range    'déclare la variable pl (PLage)
    Dim dico As Object    'déclare la variable dico (DICtiOnnaire)
    Dim Cel As Range, Cel2 As Range   'déclare la variable cel (CELLule)
    Dim temp As Variant    'déclare la variable temp (tableau TEMPoraire)
    Dim Ens() As String, Min As Integer, Max As Integer, Cpt As Integer
    Dim x As Integer, y As Integer
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")    'définit le dictionnaire dico
    With Sheets("Feuil1")    'prend en compte l'onglet "Feuil1"
        .Cells(3, 4).CurrentRegion.ClearContents    'efface les anciennes données
 
        dl = .Cells(Application.Rows.Count, 10).End(xlUp).Row    'définit la dernière ligne dl de la colonne B
        Set pl = .Range("J2:J" & dl)    'définit la plage pl
        For Each Cel In pl    'boucle sur toutes les cellules cel de la plage pl
        'MsgBox "Cel Ens = " & Cel
            Ens = Split(Cel, "-")
            Min = Mid(Ens(0), 2): Max = Mid(Ens(1), 1, Len(Ens(1)) - 1)
            '-- Nombre de valeur max à trouver
            Cpt = (Max - Min) + 1: y = 1
            For Each Cel2 In .Range("A2:A13000")
                If Cel2 >= Min And Cel2 <= Max Then
                    dico(Cel) = dico(Cel) + 1  'alimente le dictionnaire
                    y = y + 1
               ElseIf y > Cpt Then
                    Exit For
                End If
            Next Cel2
        Next Cel    'prochaine cellule de la boucle
        temp = dico.keys    'récupère le dictionnaire sans doublons
        Call Tri(temp, LBound(temp), UBound(temp))    'lance la procédure de tri croissant du tableau temp
        [C1] = "Ensemble": [D1] = "Total"
        For x = 0 To UBound(temp)    'boucle sur tous les éléments du tableau tri
            .Cells(x + 2, 3).Value = temp(x)     'place l'étiquette
            .Cells(x + 2, 4).Formula = dico.Item(temp(x)) 'place le total résultant
        Next x    'prochain élément de la boucle
    End With    'fin de la prise en compte de l'onglet "BDD"
    Application.ScreenUpdating = True
End Sub
 
Sub Tri(a As Variant, gauc As Integer, droi As Integer)    'tiré du site de Jacques BOISGONTIER http://boisgontierjacques.free.fr/
    Dim ref As Variant
    Dim g As Integer, d As Integer
    Dim tmp As Variant
 
    ref = a((gauc + droi) \ 2)
    g = gauc: d = droi
    Do
        Do While a(g) < ref: g = g + 1: Loop
        Do While ref < a(d): d = d - 1: Loop
        If g <= d Then
            tmp = a(g): a(g) = a(d): a(d) = tmp
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call Tri(a, g, droi)
    If gauc < d Then Call Tri(a, gauc, d)
End Sub

Merci d'avance.

26/09/2012, 00h00
apt

Bonsoir,

On supprimmant cette ligne, les valeur seront affichées :

Code:

Call Tri(temp, LBound(temp), UBound(temp)) 'lance la procédure de tri croissant du tableau temp

Pourquoi, je ne sais pas !!!

En plus le tri croissant, n'est pas bien fait.

Au lieu d'avoir :

[0-5]
[6-8]
[9-15]
[16-21]
[22-25]
[30-52]

J'ai :

[0-5]
[16-21]
[22-25]
[30-52]
[6-8]
[9-15]

:calim2:
26/09/2012, 01h06
Philippe Tulliez

Bonjour,
Le tri est correct parce-que c'est une chaîne de caractères et pas un nombre.
Dans une chaîne de caractères [600] est plus grand que [1000]
D'ailleurs si tu places des nombres dans une colonne A, que tu les copies en colonne D en les convertissant en caractères et que tu fais un tri sur les 2 colonnes séparément tu constateras par toi même la différence.

Une autre approche

Code:

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
Sub CompteOccurences()
Dim Tb As Range, c As Range
Dim Plage As String
Dim i As Long
Dim Tmp
 
Application.ScreenUpdating = False
With Worksheets("Feuil1")
    Set Tb = .Range("J2", .Cells(.Rows.Count, "J").End(xlUp))
    Tb.Offset(0, 1).ClearContents
    Plage = "$A$2:" & .Cells(.Rows.Count, "A").End(xlUp).Address
    For Each c In Tb
        Tmp = Extrema(c)
        If IsArray(Tmp) Then
            With c.Offset(0, 1)
                .Formula = "=SUMPRODUCT((" & Plage & ">=" & Tmp(0) & ")*(" & Plage & "<=" & Tmp(1) & ")*1)"
                .Value = .Value
            End With
            c.Offset(0, 2) = Tmp(0)
        End If
    Next c
    Tb.Resize(, 3).Sort Key1:=Tb.Offset(0, 2).Resize(1, 1), Order1:=xlAscending, Header:=xlNo
    Tb.Offset(0, 2).ClearContents
    Set Tb = Nothing
End With
End Sub
 
Private Function Extrema(ByVal Str As String)
 
Str = Replace(Str, "[", "")
Str = Replace(Str, "]", "")
If InStr(Str, "-") Then Extrema = Split(Str, "-")
End Function

Bonsoir corona, mercatog,

Merci pour réponses.

J'ai adapté le code pour qu'il soit ainsi :

Code:

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
Sub CompteOccurences()
    Dim Tb As Range, C As Range
    Dim Plage As String
    Dim i As Long
    Dim Tmp
 
    Application.ScreenUpdating = False
    With Worksheets("Feuil1")
        Set Tb = .Range("J2", .Cells(.Rows.Count, "J").End(xlUp))
        Tb.Offset(0, -5).ClearContents
        Plage = "$A$2:" & .Cells(.Rows.Count, "A").End(xlUp).Address
        For Each C In Tb
            Tmp = Extrema(C)
            If IsArray(Tmp) Then
                'With c.Offset(0, 1)
                C.Offset(0, -7).Value = C
                With C.Offset(0, -6)    ' Colonne C
                    .Formula = "=SUMPRODUCT((" & Plage & ">=" & Tmp(0) & ")*(" & Plage & "<=" & Tmp(1) & ")*1)"
                    .Value = .Value
                End With
                'c.Offset(0, 2) = Tmp(0)
                C.Offset(0, -5) = Tmp(0)
            End If
        Next C
        'Tb.Resize(, 3).Sort Key1:=Tb.Offset(0, 2).Resize(1, 1), Order1:=xlAscending, Header:=xlNo
        'Tb.Offset(0, 2).ClearContents
        Tb.Offset(0, -7).Resize(, 3).Sort Key1:=Tb.Offset(0, -5).Resize(1, 1), Order1:=xlAscending, Header:=xlNo
        Tb.Offset(0, -5).ClearContents
 
        Set Tb = Nothing
    End With
End Sub

Une modification ?

Merci.