Numéro ID unique

[eagleyes90]

Bonjour,

beaucoup de posts sur le sujet mais je n'ai pas trouvé de solution adaptable à mon problème alors voilà:

- Je recherche une macro pour générer des numéro ID unique en colonne A constitué de la première lettre du client indiqué en colonne B et d'un numéro (démarrant par 1)

- Caractéristiques:

* Dès que l'on rentre le nom d'un nouveau client, le numéro est généré automatiquement
* Si l'on supprime une ligne pas de renumérotation chaque client conserve son numéro unique.

voir l'exemple attaché pour mieux comprendre.

Merci par avance.

 

[Softmama]

Re : Numéro ID unique

Bonjour,

Une solution en pièce jointe : entre tes données en colonne I. Un numéro unique s'incrémente pour chaque lettre. Le fichier garde en mémoire ce numéro même si les lignes sont effacées.

 

[Fred0o]

Re : Numéro ID unique

Bonjour eagleyes90, Softmama,

Bravo Softmama pour ta solution élégante qui permet d'incrémenter une liste à travers la gestion de plages nommées qui font référence à un nombre.

Je ne connaissais pas cette astuce mais je vais m'empresser de l'utiliser !

A+

 

[ROGER2327]

Re : Numéro ID unique

Bonjour à tous

Une autre proposition dans le classeur joint.

[COLOR=DarkSlateGray][B]Private Sub Worksheet_Change(ByVal Target As Range)
Dim ltr$, ind%, MInd, oCel As Range, x As Object
  With [C4]
    Set x = Intersect(.Resize(Rows.Count - .Row, 1), Target)
    If Not x Is Nothing Then[/B][/COLOR][COLOR=DarkSlateGray][B]
      [COLOR=red]Application.Calculation = -4135[/COLOR][/B][/COLOR]
      [COLOR=DarkSlateGray][B]On Error GoTo DefRef
      MInd = Evaluate(ThisWorkbook.Names("MaxIndex").Value)
      On Error GoTo 0
      For Each oCel In x.Cells
        If IsEmpty(oCel) Then
          Application.EnableEvents = 0
          oCel.Offset(0, -1).Value = ""
          Application.EnableEvents = 1
        Else
          If oCel.Offset(0, -1).Value = "" Then
            ltr = UCase(Left$(oCel.Value, 1))
            ind = Asc(ltr) - 64
            If ind < 1 Or 26 < ind Then ltr = "#": ind = 27
            MInd(ind) = MInd(ind) + 1
            Application.EnableEvents = 0
            oCel.Offset(0, -1).Value = ltr & Format(MInd(ind), "00000")
            Application.EnableEvents = 1
          End If
        End If
      Next oCel
      ThisWorkbook.Names.Add Name:="MaxIndex", RefersTo:=MInd
      Application.Calculation = -4105
    End If
  End With
Exit Sub
[COLOR=DarkOrange]' Initialisation[/COLOR]
DefRef:
  rst
  Resume
End Sub

Sub rst()
  ThisWorkbook.Names.Add Name:="MaxIndex", RefersTo:=Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
End Sub[/B][/COLOR]

dans le module de la feuille de saisie.

Code corrigé (en rouge), voir message suivant.
​

ROGER2327
#4717

Lundi 9 Sable 138 (Saint Sagouin, homme d'Etat, SQ)
19 Frimaire An CCXIX
2010-W49-4T14:02:46Z

 

[ROGER2327]

Re : Numéro ID unique

Suite…

J'ai corrigé une erreur (interversion de lignes) dans le code du message précédent.

Ci-joint le fichier corrigé.
​

ROGER2327
#4724

Mercredi 11 Sable 138 (Nativité de Saint Grabbe, scherziste, SQ)
21 Frimaire An CCXIX
2010-W49-6T00:41:19Z

Postscriptum : fichier modifié et déplacé au message #8 pour tenir des modifications dans la demande (voir #6).

 

[eagleyes90]

Re : Numéro ID unique

Bonjour merci pour vos solutions. Encore une question, que dois-je modifier dans le code pour que les résultats s'affichent en colonne A plutot qu'en colonne n-1?

 

[sigismond]

Re : Numéro ID unique

Bonjour le forum, eagleyes90, Softmama, Fred0o et ROGER2327

Bravo à Softmama pour l'élégance de la solution (+1), je connaissais l'endroit pour y placer des constantes comme la TVA mais on peut y mettre des variables également.

eagleyes90, si tu veux le résultat dans la colonne A, il te faudra écrire le nom dans la colonne B et modifier le code comme suit :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Lettre As String, MaxN As String

'If Left$(Target.Address, 3) = "$I$" Then  *  *  *  *  Remplacer par :

If Left$(Target.Address, 3) = "$B$" Then

    Application.EnableEvents = False
    Lettre = UCase(Left$(Target, 1))
    MaxN = "MaxNumber" & Lettre
    Target(1, 0) = Lettre & Format(Evaluate([MaxN]) + 1, "00")
    ActiveWorkbook.Names.Add Name:=MaxN, RefersTo:="=" & Evaluate([MaxN]) + 1
    Application.EnableEvents = True
End If
End Sub

Bonne journée.

Sigismond

 

[ROGER2327]

Re : Numéro ID unique

Re…

Bonjour merci pour vos solutions. Encore une question, que dois-je modifier dans le code pour que les résultats s'affichent en colonne A plutot qu'en colonne n-1?

Une solution permettant de choisir facilement la zone de saisie et la colonne d'affichage des identifiants : il suffit d'une adaptation dans ces deux lignes de code :

col = "A" 'Colonne des identifiants (1 ou "A", 2 ou "B", …, 28 ou "AB", …)
With [C4] 'Première cellule de saisie

Ensemble du code (à placer dans le module de la feuille concernée) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ltr$, ind%, col, MInd, oCel As Range, x As Object
  col = "A" 'Colonne des identifiants (1 ou "A", 2 ou "B", …, 28 ou "AB", …)
  With [C4] 'Première cellule de saisie
    col = colNum(col) - .Column
    Set x = Intersect(.Resize(Rows.Count - .Row, 1), Target)
    If Not x Is Nothing Then
      Application.Calculation = -4135
      On Error GoTo DefRef
      MInd = Evaluate(ThisWorkbook.Names("MaxIndex").Value)
      On Error GoTo 0
      For Each oCel In x.Cells
        If IsEmpty(oCel) Then
          Application.EnableEvents = 0
          oCel.Offset(0, col).Value = ""
          Application.EnableEvents = 1
        Else
          If oCel.Offset(0, col).Value = "" Then
            ltr = carNet(UCase(Left$(oCel.Value, 1)))
            ind = Asc(ltr) - 64
            If ind < 1 Or 26 < ind Then ltr = "#": ind = 27
            MInd(ind) = MInd(ind) + 1
            Application.EnableEvents = 0
            oCel.Offset(0, col).Value = ltr & Format(MInd(ind), "00000")
            Application.EnableEvents = 1
          End If
        End If
      Next oCel
      ThisWorkbook.Names.Add Name:="MaxIndex", RefersTo:=MInd
      Application.Calculation = -4105
    End If
  End With
Exit Sub
' Initialisation
DefRef:
  rst
  Resume
End Sub

Sub rst()
  ThisWorkbook.Names.Add Name:="MaxIndex", RefersTo:=Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
End Sub

Private Function carNet$(s$)
Dim rEq$, oEq$
  carNet = s
  rEq = " ÀÁÂÃÄÅÆÇÈÉÊËÐÌÍÎÏÑÒÓÔÕÖŒÙÚÛÜÝŸ"
  oEq = " AAAAAAACEEEEEIIIINOOOOOOUUUUYY"
  On Error Resume Next
  carNet = Mid$(oEq, InStr(1, rEq, s, vbBinaryCompare), 1)
  On Error GoTo 0
End Function

Function colNum(x As Variant)
  Select Case VarType(x)
    Case 2 To 5, 17: colNum = colValid(Int(x))
    Case 8
      x = UCase(x)
      colNum = Asc(Right$(x, 1)) - 64
      If Len(x) > 1 Then colNum = colNum + 26 * (Asc(Mid$(StrReverse(x), 2, 1)) - 64)
      colNum = colValid(colNum)
    Case Else: Error 5
  End Select
End Function

Function colValid(x)
  colValid = ((Columns.Count + 2 + x - Abs(Columns.Count - x)) / 2 + Abs((Columns.Count - 2 + x - Abs(Columns.Count - x)) / 2)) / 2
End Function

• Ce code crée et utilise une seule variable nommée (MaxIndex).
• Il permet la réinitialisation facile des compteurs : il suffit de supprimer la variable nommée MaxIndex ou d'exécuter la procédure rst.
• Il ne modifie pas l'identifiant si on corrige une faute d'orthographe (remplacement d'une lettre minuscule par la même en majuscule, par exemple).
• Il supprime l'identifiant si on supprime un nom. (L'identifiant supprimé ne sera bien sûr pas recréé par la suite.)
  
  [*]Il ne plante pas en désactivant les procédures évènementielles si :
  

  1. - on colle simultanément plusieurs noms dans la colonne de saisie ;
  2. - par respect de l'identité des personnes, on saisit un nom commençant par autre chose que A, B, …, Z, a, b, …, z. (Ève et Œdipe, par exemple…) ;
  3. - on efface un nom dans la zone de saisie ;
  4. - on a oublié de définir le nom MaxIndex avant de commencer.

ROGER2327
#4733

Vendredi 13 Sable 138 (Saint Flaive, concierge, SQ)
23 Frimaire An CCXIX
2010-W50-1T23:43:46Z

 

[eagleyes90]

Re : Numéro ID unique

Bonjour à tous, C'est parfait. J'ai bien compris et vous avez réglé mon problème. Merci Beaucoup.