Private Sub Worksheet_Change(ByVal Target As Range)
Dim colNom%, colID%, oCl&, tf As Boolean
Dim n&, oPlg As Object, oCel As Range
Dim h$, k$, ck&, nLieux&, corLieux$()
Dim nMax&, nPatron$, nFormat$, w&
Const Champ_Nom$ = "Secteur" 'intitulé de la colonne des Noms
Const Champ_ID$ = "ID Enfants" 'intitulé de la colonne des Identifiants
Const nk As Byte = 2 'longueur du préfixe littéral
Const ww$ = "-ENF-" 'séparateur
Const nc As Byte = 3 'longueur du postfixe numérique
'Recherche des n° de colonnes des champs :
oCl = Cells(1, Columns.Count).End(xlToLeft).Column
With Range(Cells(1, 1), Cells(1, oCl))
For colNom = 1 To oCl
If .Cells(1, colNom) Like Champ_Nom Then Exit For
Next
For colID = 1 To oCl
If .Cells(1, colID) Like Champ_ID Then Exit For
Next
End With
'Si les champs de données existent :
If colNom <= oCl And colID <= oCl Then
'Définition de la plage de données à traiter :
Set oPlg = Intersect(Target, Columns(colNom).Resize(Rows.Count - 1, 1).Offset(1, 0))
'Contrôle de l'existence de données à traiter :
If Not oPlg Is Nothing Then
' Calcul des paramètres relatifs au postfixe numérique :
nMax = 10 ^ nc - 1: nPatron = String(nc, "#"): nFormat = String(nc, "0")
' Normalisation des noms de secteur :
nLieux = [Lieux].Count
ReDim corLieux(1 To nLieux)
For ck = 1 To nLieux: corLieux(ck) = corCar([Lieux].Cells(ck)): Next
Application.Calculation = xlCalculationManual
'Traitement séquentiel des données :
For Each oCel In oPlg.Cells
If Not IsEmpty(oCel.Value) Then
'Recherche du préfixe de la donnée courante :
h = corCar(oCel.Value)
k = Left$(h, nk) & ww
For ck = nLieux To 1 Step -1
If h = corLieux(ck) Then Exit For
Next
'Si la donnée correspond à un préfixe valide, détermination du rang du rang "n" du dernier postfixe associé :
If ck Then
n = Feuil2.Cells(ck, 1).Offset(, 1).Value
'Vérification de la disponibilité d'un postfixe valide :
If n >= nMax Then
MsgBox "Tous les identifiants ont été attribués." & vbLf & "Désolé..."
Else
'Contrôle de la présence antérieure d'un identifiant et demande sur l'éventuelle création d'un nouvel identifiant :
If Not IsEmpty(oCel.Offset(0, colID - colNom)) And Not IsEmpty(oCel) Then
tf = MsgBox("Voulez-vous remplacer l'ancien idendifiant ?", vbYesNo) = vbYes
End If
'Le cas échéant, création d'un nouvel identifiant :
If (IsEmpty(oCel.Offset(0, colID - colNom)) Or tf) And Not IsEmpty(oCel) Then
n = n + 1
Application.EnableEvents = False
oCel.Offset(0, colID - colNom).Value = k & Format(n, nFormat)
'Mémorisation du rang du postfixe :
Feuil2.Cells(ck, 1).Offset(, 1).Value = n
Application.EnableEvents = True
End If
End If
End If
End If
Next
Application.Calculation = xlCalculationAutomatic
End If
Set oPlg = Nothing
Erase corLieux
End If
'Suite de la procédure Worksheet_Change
End Sub
Private Function corCar$(x$)
Const rEq = " ÀÁÂÃÄÅÂÆÇÈÉÊËÊÐÌÍÎÏÑÒÓÔÕÖŒÙÚÛÜÝŸ" '(à compléter)
Const oEq = "*AAAAAAAACEEEEEEIIIINOOOOOOUUUUYY"
Dim i&
x = UCase(x)
For i = 1 To Len(x)
On Error Resume Next
Mid$(x, i, 1) = Mid$(oEq, InStr(1, rEq, Mid$(x, i, 1), vbBinaryCompare), 1)
On Error GoTo 0
Next
corCar = x
End Function
Bonjour à tous,
