Option Compare Text 'la casse est ignorée
Private Sub Worksheet_Change(ByVal target As Range)
Dim tablo, d As Object, i As Long, num() As String, x As String, p As Byte
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo): d(tablo(i, 1) & Chr(1) & tablo(i, 2)) = "": Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [D2] '1ère cellule à adapter
.Resize(Rows.Count - 1, 3).ClearContents 'RAZ
If d.Count Then
With .Cells(1, 2).Resize(d.Count)
.Value = Application.Transpose(d.keys) 'Transpose limitée à 65536 lignes
.TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
.Resize(, 2).Sort .Columns(1), xlAscending, .Columns(2), , xlAscending, Header:=xlNo 'tri alphabétique
tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim num(1 To UBound(tablo), 1 To 1)
num(1, 1) = "1.1"
For i = 1 To UBound(tablo) - 1
x = num(i, 1): p = InStr(x, ".")
If tablo(i + 1, 1) = tablo(i, 1) Then
num(i + 1, 1) = Left(x, p) & Mid(x, p + 1) + 1
Else
num(i + 1, 1) = Val(Left(x, p)) + 1 & ".1"
End If
Next
.Columns(0) = num
End With
End If
End With
Application.EnableEvents = True
End Sub