Autres Recherche d'un doublon dans une feuille excel 2007

[jlr sxp]

Bonjour,
J'ai un tableau avec plusieurs colonnes de 100.000 code EAN128 et je recherche les doublons sur cette feuille.
Peut'on dans une nouvelle feuille créér un rapport qui donne le nombre total de code EAN 128
et le nombre de doublons détectés ?
Merci d'avance
Jean luc

 

[Robert]

Bonjour Jean Luc, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (onglet)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DC As Integer 'déclare la variable DC (Dernière Colonne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim NC As Long 'déclare la variable NC (Nombre de Code)
Dim NCU As Long 'déclare la variable NCU (Nombre de Codes Uniques)
Dim NCD As Long 'déclare la variable NCD (Nombre de Codes en Doublon)

Set O = Worksheets("Feuil1") 'définit l'onglet O
O.Cells.Interior.ColorIndex = xlNone 'supprime les couleurs dans l'onglet
Set D = CreateObject("Scripting.Dictionary") 'de'finit le dictionnaire D
DL = O.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet O
DC = O.Cells(1, Application.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne éditée de la ligne 1 de l'onglet O
TV = O.Range(O.Cells(1, 1), O.Cells(DL, DC)) 'définit le tableau des valeurs TV
For I = 1 To DL 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV
    For J = 1 To DC 'boucle 2 : sur toutes les Colonne J du tableau des valeurs TV
        'si la donnée ligne I colonne J de TV n'existe pas dans le dictionnaire D, alimente le dictionanire D avec la donnée, sinon, colore la cellule en vert
        If TV(I, J) <> "" Then If Not D.exists(TV(I, J)) Then D(TV(I, J)) = "" Else O.Cells(I, J).Interior.ColorIndex = 4
    Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
NC = Application.WorksheetFunction.CountA(O.Range(O.Cells(1, 1), O.Cells(DL, DC))) 'définit le nombre de codes NC
NCU = D.Count 'définit el nombre de code uniques NCU
NCD = NC - NCU 'définit le nombre de codes en doublon NCD
MsgBox "Il a " & NC & " codes au total. Dont " & NCD & "doublon(s), repéré(s) en vert" 'message
End Sub

 

[jlr sxp]

Ouahhh !!!
Merci, je vais tester et tu donneras de nouvelles.
merci
Jean Luc

 

[jlr sxp]

J'ai testé et ça marche du feu de dieux !!
par contre, pour compliquer et abuser de ta générosité....
peut'on générer une nouvelle feuille avec le rapport ?
et nec plus ultra une liste avec les codes qui sont en doublons ?
Je suis conscient que ça complique, mais on sait jamais.
encore bravo !!!
Jean Luc

 

[Robert]

Re,

Essaie comme ça :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (onglet)
Dim R As Worksheet 'déclare la variable R (Repport)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DC As Integer 'déclare la variable DC (Dernière Colonne)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Long 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim NC As Long 'déclare la variable NC (Nombre de Code)
Dim NCU As Long 'déclare la variable NCU (Nombre de Codes Uniques)
Dim NCD As Long 'déclare la variable NCD (Nombre de Codes en Doublon)
Dim DEST As Range 'déclare la variable DEST (cellule de DEStination)

Set O = Worksheets("Feuil1") 'définit l'onglet O
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set R = Worksheets("Report") 'définit l'onglet R
If Err <> 0 Then 'condition : si une erreur a été générée
    Worksheets.Add after:=Worksheets(1) 'ajoute un onglet vierge en seconde position
    Set R = ActiveSheet 'définit l'onglet R
    R.Name = "Report" 'renomme l'onglet R
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
R.Cells.Clear 'efface le contenu de l'onglet R
O.Cells.Interior.ColorIndex = xlNone 'supprime les couleurs dans l'onglet
Set D = CreateObject("Scripting.Dictionary") 'de'finit le dictionnaire D
DL = O.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet O
DC = O.Cells(1, Application.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne éditée de la ligne 1 de l'onglet O
TV = O.Range(O.Cells(1, 1), O.Cells(DL, DC)) 'définit le tableau des valeurs TV
For I = 1 To DL 'boucle 1 : sur toutes les lignes I du tableau des valeurs TV
    For J = 1 To DC 'boucle 2 : sur toutes les Colonne J du tableau des valeurs TV
        If TV(I, J) <> "" Then 'condition 1 : si la donnée n'est pas vide
            If Not D.exists(TV(I, J)) Then 'condition 2 : si la donnée ligne I colonne J de TV n'existe pas dans le dictionnaire D
                D(TV(I, J)) = "" 'alimente le dictionanire D avec la donnée
            Else 'sinon
                Set DEST = IIf(R.Range("A1").Value = "", R.Range("A1"), R.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0)) 'définit la cellule de destination DEST
                With O.Cells(I, J) 'prend em compte la cellule ligne I colonne J
                    .Interior.ColorIndex = 4 'colore la cellule en vert
                    .Copy DEST 'cipie la cellule dans DEST
                End With 'fin de la prise en compte...
            End If 'fin de la condition 2
        End If 'fin de la condition 1
    Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
NC = Application.WorksheetFunction.CountA(O.Range(O.Cells(1, 1), O.Cells(DL, DC))) 'définit le nombre de codes NC
NCU = D.Count 'définit el nombre de code uniques NCU
NCD = NC - NCU 'définit le nombre de codes en doublon NCD
R.Range("B1").Value = "Nombre de codes" 'écrit en B1
R.Range("B2").Value = NC 'renvoie en NC en B2
R.Range("D1").Value = "Nombre de doublons" 'écrit en D1
R.Range("D2").Value = NCD 'renvoie en NCD en D2
R.Columns("A:D").AutoFit 'largeur automatique des colonnes A à D
R.activate
End Sub

 

[jlr sxp]

merci, c'est très fort.
Jean Luc