Sub u_47()
    Application.ScreenUpdating = False
    a = 3                    'первая строка номеров
    b = Cells(Rows.Count, "b").End(xlUp).Row    'нижняя строка столбца B
    If b > a - 1 Then Range("c" & a & ":c" & b).ClearContents 'сотрем НОМЕР
    Dim arr()
    n = 0
    For d = 1 To b - a + 1
        e = Chr(Application.RoundUp(d / 500, 0) + 64) 'буква
        f = (d - 1) Mod 500 + 1 'число
        g = e & f
        h = Application.Match(g, Range("d" & a & ":d" & b), 0) 'ищем номер в подномере
        If IsNumeric(h) = False Then 'если не нашли, запишем в массив
            ReDim Preserve arr(n)
            arr(n) = g
            n = n + 1
        End If
    Next
    s = 0
    For i = a To b
        j = Range("d" & i).Value
        If j = "" Then 'если допномер пуст, запишем из массива
            Range("c" & i) = arr(s)
            s = s + 1
        Else 'иначе из соседних ячеек
            Range("c" & i) = Range("d" & i).Value & "-" & Range("e" & i).Value
        End If
    Next
    Application.ScreenUpdating = True
End Sub