Mise à jour des doublons

Option Explicit

Sub email()
Const arob As String = "@"
Dim ws As Worksheet
Dim emails As Scripting.Dictionary
Dim ligne As Range
Dim email As String, pn As String, atdom As String, lastd As String, deb As String
Dim posa As Integer, lastn As Integer

Set ws = Sheets("email")
Set emails = New Scripting.Dictionary
For Each ligne In ws.UsedRange.Rows
    email = ligne.Cells(1, 1)
    Do While emails.Exists(email)
        posa = InStr(email, arob)
        pn = Left(email, posa - 1)
        atdom = Right(email, Len(email) - posa + 1)
        lastd = Right(pn, 1)
        If IsNumeric(lastd) Then
            lastn = lastd
            deb = Left(pn, Len(pn) - 1)
            If lastn = 9 Then
                pn = deb & "01"
            Else
                pn = deb & (lastd + 1)
            End If
        Else
            pn = pn & "0"
        End If
        email = pn & atdom
    Loop 'Do While emails.Exists(email)
    emails.Add email, 0
    ligne.Cells(1, 1) = email
Next ligne

End Sub