Option Explicit

Sub codifica()
Dim j As Long, i As Long, prev As String, cell As Range

    [a:a].Sort key1:=[a1], order1:=xlAscending, header:=xlNo
    
    j = 1
    prev = [a1]
    For Each cell In [a:a]
        If Trim(cell) = "" Then Exit For
        If cell = prev Then
            i = i + 1
        Else
            prev = cell
            i = 1
            j = j + 1
        End If
        cell.Offset(, 1) = UCase(Left(cell, 2)) & Format(j, "0000") & Format(i, "_00")
    Next
    
End Sub