repérer des doublons en VBA Résolu

Question

Bonjour, 

Je souhaiterais - sans utiliser la validation des données - vérifier que mes numéros de commande (situés tous en colonne A) sont uniques. 
Je sais qu'on peut détecter les doublons avec la formule : NB.SI($A$1:$A$20;A1)>1
Est-il possible de transférer cela en code VBA. 

Voilà la code que j'ai commencé à taper : 

Sub Macro_Numero_Reference()
Dim cell As Range

Sheets("FOLLOW-UP").Select
    
Range(Range("A4"), Range("A65000").End(xlUp)).Select  'décale la cellule active d'une case sur la droite
For Each cell In selection

If   Then 'je ne sais pas quoi mettre

MsgBox "Erreur de saisie.", vbCritical, "VERIFICATION SAISIE"
cell.Value = UCase(InputBox("Saisir un nouveau numéro de référence :", "NOUVELLE COMMANDE", ""))
Calculate

End If
Next

End Sub

Merci de voter aide par avance. mcouConfiguration: Windows 7 / Internet Explorer 8.0

tuxboy · Answer

Tu peux essayer d'adapter cette fonction :


Public Sub Doublons()
Dim Col As Integer
Dim k As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim Rng As Range

  On Error GoTo FinMacro
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Sheets("FOLLOW-UP").Select
  Col = ActiveCell.Column
  If Selection.Rows.Count > 1 Then
    Set Rng = Selection
  Else
    Set Rng = ActiveSheet.UsedRange.Rows
  End If

  N = 0
  For k = Rng.Rows.Count To 1 Step -1
    Rng.Cells(k, 1).Value = RTrim(Rng.Cells(k, 1).Value)
  Next r

  For k = Rng.Rows.Count To 1 Step -1
    V = Rng.Cells(k, 1).Value
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
       Rng.Rows(k).EntireRow.Delete
       N = N + 1
    End If
  Next r

FinMacro:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

Bon courage !

pijaku · Answer

Bonjour,
Il faut que tu testes l'existence ou non dans ton dictionary des éléments que tu souhaites y ajouter :

For Each c In Range("a4", [a65000].End(xlUp))
    If Not mondico.Exists(c.Value) Then 
        mondico(c.Value) = ""
    Else
        MsgBox c.Address
    End If
    Next c

pijaku · Answer

tu n'as pas l'impression d'un tout p'tit peu exagérer???
Je t'ai tout mis au dessus tu n'avais qu'à adapter...
je fais l'effort une dernière fois...

Set mondico = CreateObject("Scripting.Dictionary")

For Each c In Range("a4", [a65000].End(xlUp))
    If Not mondico.Exists(c.Value) Then
        mondico(c.Value) = ""
    Else
'------------ICI TES ACTIONS----------------
    '---------PAR EXEMPLE :
        Set cell = c
        Call Rempli_Textbox
        c.Value = InputBox("Un doublon a été détecté. Veuillez changer le numéro de référence.", "NUMERO DE REFERENCE", Range("A2").Value + 1)
    End If
Next c

pijaku · Answer

Bonjour, 

Une incohérence apparait dans la dernière partie de ton code. 
Tu boucles sur toutes les lignes colonne A : 
For Each cell In Range("A4", [a65000].End(xlUp)) ' pour chaque cellule de la colonne A (sans les entêtes)Puis tu boucles à nouveau sur toutes les cellules vides : 
        Do While cell.Value = "" 'tant que la cellule est vide
Un simple test suffit ici : 
If cell.Value ="" Then
De plus, supposons que les dernières lignes de la colonne A ne soient pas remplies.... Elles ne seront pas traités car tu calcules la dernière ligne remplie colonne A... Il faut, pour déterminer la dernière ligne à traiter, prendre la colonne qui sera effectivement et systématiquement la plus "longue". 
Exemple avec la colonne B : 
Dim DrLig As Long 

DrLig = Range("B" & Rows.Count).End(xlUp).Row 
For Each cell In Range("A4:A" & DrLig) ' pour chaque cellule de la colonne A (sans les entêtes) 
        If cell.Value = "" 'tant que la cellule est vide 
            Call Rempli_Textbox 'rempli l'adresse et la valeur (vide) de la cellule en question dans le formulaire verification_ALL 
            cell.Value = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE", Range("A2").Value + 1) 'affecte une valeur à la cellule vide à travers une inputbox 
        End If 
Next cell

Après, pour parfaire le code, tu peux aussi empêcher la saisie de n'importe quoi dans l'Inputbox. En supposant, ici, que l'utilisateur saisisse "toto" dans l'InputBox Numéro de référence... Tu vois à quoi ressemblera ta base d'ici quelques temps? 
Tu peux tester donc le résultat avant de l'inscrire dans ta cellule. 
Exemple pour imposer la saisie d'un nombre à deux chiffres : 
Dim rep 

Do 
    rep = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE") 
'on boucle tant que rep n'est pas numérique ou que son nombre de caractère est différent de 2 : 
Loop While Not IsNumeric(rep) Or Len(rep) <> 2
cell.Value = rep
Cordialement, 
Franck P

pijaku · Answer

1- Do - Loop While
Il s'agit de la même chose que Do While - Loop. Fais tant que ou boucle tant que...
A part que. Si, dans ton cas tu écris :
Dim rep
Do While Not IsNumeric(rep)
    rep = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE")
Loop
Sans rien ajouter, l'InputBox n'apparait pas puisque rep est vide donc considéré par VBA comme égale à zéro, donc numérique.....
Par contre, en demandant de boucler tant que, là elle apparait :
Do
    rep = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE")
Loop While Not IsNumeric(rep)
Pour que cela fonctionne avec Do While, tu as deux choix :
Code pas beau :
Dim rep
rep = "a"
Do While Not IsNumeric(rep)
    rep = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE")
Loop
Code pas beau non plus :
Dim rep
rep = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE")
Do While Not IsNumeric(rep)
    rep = InputBox("Numéro de référence inexistant. Veuillez en indiquer un.", "NUMERO DE REFERENCE")
Loop

2- dernière ligne non vide :
Ce code renvoie la dernière ligne absolue non vide dans la feuille, peu importe la colonne la plus "longue".	
Attention: Si des lignes sont supprimées dans la plage, enregistrez préalablement le fichier pour que la procédure renvoie la réelle dernière ligne
Dim DerniereLigne As Long
DerniereLigne = Range("A1").SpecialCells(xlCellTypeLastCell).Row
Donc, si tu as peut être supprimé des lignes avant :
Dim DerniereLigne As Long
ActiveWorkBook.Save
DerniereLigne = Range("A1").SpecialCells(xlCellTypeLastCell).Row

Repérer des doublons en VBA

5 réponses

Discussions similaires

Newsletters