doublon appliqué sur un filtre

[moi244]

Bonjour,
Ce code me donne les doublons et le nombre de chacun des doublons dans un MessageBox, comment fairais-je pour qu'il me donne les doublons de seulement ceux qui ont une cellule vide dans la colonne B avec un filtre égale à vide dans la colonne B.
Donc je veux excluer ceux que c'est ecrit "éxpiré" dans les cellules B.
A B
x éxpiré
x
x
a
a
c
v
b
b
a
a éxpiré
a
a

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
60
61
62
63
64
65
Private Sub CommandButton3_Click()
 
    Dim f1 As Worksheet
    Dim Plage As Range
    Dim Tableau(), Resultat() As String
    Dim i As Integer, j As Integer, m As Integer
    Dim Un As Collection
    Dim Doublons As String
 
    Set Un = New Collection
    'La plage de cellules (sur une colonne) à tester
    Set Plage = Range("E1:E" & Range("E65536").End(xlUp).Row)
 
 
    Tableau = Plage.Value
 
    On Error Resume Next
    'boucle sur la plage à tester
    For i = 1 To Plage.Count
 
        ReDim Preserve Resultat(2, m + 1)
 
        'Utilise une collection pour rechercher les doublons
        '(les collections n'acceptent que des données uniques)
        Un.Add Tableau(i, 1), CStr(Tableau(i, 1))
 
        'S'il y a une erreur (donc présence d'un doublon)
        If Err <> 0 Then
 
            'boucle sur le tableau des doublons pour vérifier s'il a déjà
            'été identifié
            For j = 1 To m + 1
                'Si oui, on  incrémente le compteur
                If Resultat(1, j) = Tableau(i, 1) Then
                    Resultat(2, j) = Resultat(2, j) + 1
                    Err.Clear
                    Exit For
                End If
            Next j
 
                'Si non, on ajoute le doublon dans le tableau
                If Err <> 0 Then
                    Resultat(1, m + 1) = Tableau(i, 1)
                    Resultat(2, m + 1) = 1
 
                    m = m + 1
                    Err.Clear
 
                End If
        End If
    Next i
 
    '----- Affiche la liste et le nombre de doublons --------
    For j = 1 To m
        Doublons = Doublons & Resultat(1, j) & " --> " & _
                    Resultat(2, j) & vbCrLf
    Next j
 
    MsgBox Doublons
 
    Set Un = Nothing
 
 
 
End Sub

[Qwazerty]

Salut

Une solution avec un dictionnaire sera plus efficace je pense, voila un code qui correspond à ce que tu cherches à faire je pense, j'ai commenté le code, mais si tu as des questions n'hésite pas (enfin après avoir fait une petite recherche ).

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
Sub NbrDoublon()
'Activer les reférence Microsoft Scripting Runtime dans Menu "Outils", "Références..."
Dim DicoDoublon As New Dictionary
Dim TheCell As Range
Dim i As Integer
Dim Doublons As String
 
With ThisWorkbook.Sheets("Feuil1") 'a adapter
    'On boucle sur chaque cellule de la colonne A
    'Si tu veux changer la colonne de référence qui détermine le nombre de ligne
    'Remplace le "E" par la colonne que tu souhaites utiliser
    For Each TheCell In .Range("A1:A" & .Cells(.Rows.Count, "E").End(xlUp).Row)
        'On verifie que la cellule en colonne B est vide
        If TheCell.Offset(0, 1).Value = "" Then
            'On verifie si la valeur existe déjà dans le dico
            If DicoDoublon.Exists(TheCell.Value) Then
                'On va incrémenter le nombre de fois que la valeur est vu
                'Pour cela on ajoute 1 au contenu de la clef
                DicoDoublon(TheCell.Value) = DicoDoublon(TheCell.Value) + 1
            Else
                'La valeur n'existe pas, on la crée
                DicoDoublon.Add TheCell.Value, 1 'le 1 correspond au nombre de fois que la valeur est rencontrée
            End If
        End If
    Next
End With
 
'Si ensuite tu souhaites ne garder que les valeur ayant un doublon,
'il suffit de supprimer toutes les clefs ayant 1 comme valeur
For i = DicoDoublon.Count - 1 To 0 Step -1
    'On regarde combien de fois apparait l'item i
    If DicoDoublon.Items(i) = 1 Then
        'S'il n'apparait qu'une fois, on le supprime (il n'a pas de doublon)
        DicoDoublon.Remove DicoDoublon.Keys(i)
    Else
        'Sinon on rajoute le contenu dans le msgbox
        Doublons = Doublons & DicoDoublon.Keys(i) & " --> " & DicoDoublon.Items(i) & vbCrLf
    End If
Next
 
'On affiche le texte préparé
MsgBox Doublons, vbInformation
 
'Le DicoDoublon ne contient plus que les doublons avec le nombre de fois que la valeur apparait
'A toi de voir ce que tu souhaites en faire
End Sub

Si tu travail sur un grand nombre d'enregistrements, il est possible d'utiliser un tableau dans la 1ère partie du code afin d'accélérer le remplissage du Dico.


++
Qwaz