Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim i%, k%
Dim s$
Dim r As Range
i = 7 'номер строки первого сотрудника
s = Range("b" & i).Value
Range("b" & i).Offset(1, 0).Select
Do While ActiveCell.Value <> ""
    If ActiveCell.Value = s Then
        Set r = ActiveCell
        Range(r, r.Offset(-1, 0)).MergeCells = True
        Range(r.Offset(0, 1), r.Offset(-1, 1)).MergeCells = True
        Range(r.Offset(0, 2), r.Offset(-1, 2)).MergeCells = True
        Range(r.Offset(0, -1), r.Offset(-1, -1)).MergeCells = True
    End If
    s = ActiveCell.Value
    ActiveCell.Offset(1, 0).Select
Loop
With Range("b" & i & ":d" & ActiveCell.Row)
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
End With
With Range("a" & i & ":a" & ActiveCell.Row)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
End With
Range("b" & i - 1).Offset(1, 0).Select
k = 1
Do While ActiveCell.Value <> ""
    ActiveCell.Offset(0, -1).Value = k
    ActiveCell.Offset(1, 0).Select
    k = k + 1
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True