Compter des doublons en VBA.

Version imprimable

Bonjour,

j'essaye en tâtonnant d'automatiser une tache avec un peut de VBA.

J'ai une liste dans une feuille qui recense les dossiers traités par la hotline et je cherche à faire un "top 5" des applications qui posent le plus de probleme.
J'ai donc un tableau dont la colonne "D" contiens les nom des applications mais rien n'est classé. J'ai donc essayé de compter les doublons afin d'aboutir au résultat souhaité.
voici ce à quoi je suis arrivé avec un peut de recherche :

Le code suivant se trouve sur la feuille "STATS", le tableau contenant les valeurs dans la feuille "TMP" je cherche dans un premiers temps à afficher simplement une msgbox histoire de tester avant d'adapter le code.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Dim j As Integer, plage As Range, prec As String Application.ScreenUpdating = False Set plage = Worksheets("TMP").Range("D1:D" & nbdossier) prec = "" For j = 1 To nbdossier With Application.WorksheetFunction If .CountIf(plage, Cells(j, 4)) > 1 And Cells(j, 4) <> prec Then MsgBox "Il y a " & .CountIf(plage, Cells(j, 4)) & " fois la valeur " & Cells(j, 4) End If End With prec = Cells(j, 4) Next j
Lorsque je teste le code dans la feuille qui contiens le tableau : pas de soucis tout fonctionne à merveille. Par contre si je fais le test sur une autre feuille il me trouve bien les différentes application de ma colonne D mais ne me compte pas les occurrences. J'ai tourné et retourné dans tous les sens et je ne vois pas trop où j'ai pu me planter. Si quelqu'un à une idée je suis preneur :)

Par avance merci.

Salut vindkald,

Voici le code que je te propose :

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
Sub doublon()
Dim doub As Range
Dim table() As String
Dim flag As Boolean
 
With Worksheets("Feuil3")
 
Set doub = .Range("D1")
ReDim table(1 To 2, 1 To 1)
table(1, 1) = doub
table(2, 1) = 1
 
For i = 1 To .Columns(4).Find("*", , , , , xlPrevious).Row - 1
    flag = True
    For j = LBound(table, 2) To UBound(table, 2)
        If doub.Offset(i, 0) = table(1, j) Then
            table(2, j) = table(2, j) + 1
            flag = False
            Exit For
        End If
     Next j
 
    If flag Then
        ReDim Preserve table(1 To 2, 1 To (UBound(table, 2) + 1))
 
        table(1, UBound(table, 2)) = doub.Offset(i, 0)
        table(2, UBound(table, 2)) = 1
    End If
 
Next i
 
End With
 
With Worksheets("Feuil4")
    For i = LBound(table, 2) To UBound(table, 2)
        .Range("A1").Offset(i, 0) = table(1, i)
        .Range("A1").Offset(i, 1) = table(2, i)
    Next i
End With
 
End Sub

Je regarde tous les éléments de la colonne D de ma feuille 3 et écrit les résultats sur les colonnes A et B de ma feuille 4.

Dis moi ce que tu en penses. :ccool:

Cordialement,
Kimy

24/01/2014, 15h33
vindkald

Bonjour et tout d'abord merci beaucoup pour la réponse rapide.

Cependant ma feuille "TMP" est une feuille que je rajoute temporairement pour importer des données et que je supprime ensuite je trouve que ça fait un peut lourd de créer une troisième feuille. Je cherchais plus à corriger mon code.

Quand tu écris Cells sans indiquer à quel feuille elle appartient, forcément ça prend la feuille active.

Sans trop chambouler ton code (critiquable), une petite correction

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Dim Plage As Range, c As Range, Prec As String
 
Application.ScreenUpdating = False
Set Plage = Worksheets("TMP").Range("D1:D" & nbdossier)
For Each c In Plage
    With Application.WorksheetFunction
        If .CountIf(Plage, c) > 1 And c <> Prec Then
            MsgBox "Il y a " & .CountIf(Plage, c) & " fois la valeur " & c
        End If
    End With
    Prec = c
Next j

Ton code aurait pu être

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Dim j As Integer, plage As Range, prec As String
 
Application.ScreenUpdating = False
Set plage = Worksheets("TMP").Range("D1:D" & nbdossier)
 
For j = 1 To nbdossier
    With Application.WorksheetFunction
        If .CountIf(plage, Worksheets("TMP").Cells(j, 4)) > 1 And Worksheets("TMP").Cells(j, 4) <> prec Then
            MsgBox "Il y a " & .CountIf(plage, Worksheets("TMP").Cells(j, 4)) & " fois la valeur " & Worksheets("TMP").Cells(j, 4)
        End If
    End With
    prec = Worksheets("TMP").Cells(j, 4)
Next j

24/01/2014, 17h12
vindkald

Merci beaucoup cela fonctionne à merveille !