Recherche d'un intru dans un tableau

Bonjour à tous,

Je m'occupe pour mon travail d'une liste nominative de personnes possédant un badge alarme qui permet de désactiver l'alarme, les identités de ces personnes sont répétées plusieurs fois dans un tableau car elles travaillent sur plusieurs bâtiments.

Le tableau fait 2500 lignes.

Un badge comprend son numéro d'enregistrement administratif (XXX-XX) ainsi qu'un code intégré dans celui-ci.

Ma question:

Je dois m'assurer que chaque utilisateur possède toujours le même badge, le même code.

Je dois être sûr également qu'un même code n'est attribué qu'à une seule personne.

Je me remet entre vos mains car je ne sais pas comment formuler cette recherche (même dans google).

Le but étant de souligner par une mise en forme ou autre, tous les codes identiques qui n'auraient pas le même propriétaire.

Ou inversement, souligner tous les utilisateurs qui détiendraient plusieurs codes.

Je joins un fichier qui éclaircira peut-être ma demande.

Je remercie d'avance ceux qui prendront le temps de m'aider ou m'aiguiller.

Bonne journée à vous

Bonjour,

une solution via une macro

Sub detectdouble()
'partie 1 recherche de personne avec plusieurs badges et/ou plusieurs codes
    Dim badge(3000), bcode(3000)
    Set dico = CreateObject("Scripting.Dictionary")
    dl = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To dl
        cle = Cells(i, 1) & Cells(i, 2)
        If dico.exists(cle) Then
            k = dico.Item(cle)
            msg = ""
            If badge(k) <> Cells(i, 4) Then
                msg = "badge en double avec " & badge(k)
            ElseIf bcode(k) <> Cells(i, 5) Then
                msg = "code en double avec " & bcode(k)
            End If
            Cells(i, 6) = msg
        Else
            n = n + 1
            dico.Add cle, n
            badge(n) = Cells(i, 4)
            bcode(n) = Cells(i, 5)
        End If
    Next i
'partie 2 vérification du l'unicité du code.
    Set dico = Nothing
    Erase badge
    Erase bcode
    Set dico = CreateObject("Scripting.Dictionary")
    For i = 1 To dl
        cle = Cells(i, 5)
        If dico.exists(cle) Then
            If dico.Item(cle) <> Cells(i, 1) & " " & Cells(i, 2) Then
                Cells(i, 6) = Cells(i, 6) & " " & "code en double avec " & dico.Item(cle)
            End If
        Else
            dico.Add cle, Cells(i, 1) & " " & Cells(i, 2)
        End If
    Next i
End Sub

ps : on ne vérifie pas si un même badge est utilisé par 2 personnes différentes.

Bonjour,

edit : supprimé

pas vu la réponse de h2so4

Merci pour vos réponse,

J'ai commencé à regarder la première réponse qui semble très bien fonctionner.

Mais vu que je n'aime pas appliquer sans comprendre, Google dans une fenêtre et VBA dans l'autre pour comprendre le détail des opérations effectuées.

En tout cas, je suis bluffé par votre rapidité !

Je repasse sur le site demain après avoir potassé !

Merci pour tout en attendant.

Cordialement.

Bonsoir le forum

Le problème vu sous un autre angle

A tester, restitution en Feuil2.

Option Explicit

Sub detection_doublons_badges()
Dim a, i As Long, j As Long, n As Long, dico As Object, w, txt As String
    With Sheets("Feuil1").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 2, 4, 5))
    End With
    ReDim b(1 To UBound(a, 1), 1 To 3)
    n = 1: b(1, 1) = "Noms": b(1, 2) = "Badges": b(1, 3) = "Badges_codes"
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)))
            If Not .exists(txt) Then
                n = n + 1
                b(n, 1) = txt
                Set dico = CreateObject("Scripting.Dictionary")
                dico.CompareMode = 1
                For j = 3 To UBound(a, 2)
                    b(n, j - 1) = a(i, j)
                    If a(i, j) <> "" Then dico(b(i, j - 1)) = Empty
                Next
                .Item(txt) = VBA.Array(n, dico)
            Else
                w = .Item(txt)
                For j = 3 To UBound(a, 2)
                    If a(i, j) <> "" And Not w(1).exists(a(i, j)) Then
                        b(w(0), j - 1) = b(w(0), j - 1) & ", " & a(i, j)
                        w(1)(b(i, j - 1)) = Empty
                    End If
                Next
                .Item(txt) = w
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1)
        .CurrentRegion.Clear
        With .Resize(n, 3)
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Interior.ColorIndex = 42
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
        End With
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Merci pour vos réponse,

Je grenouille toujours sur votre première proposition.

Je vous tiens au courant de l'application sur ce fichier !