Sub sdf()
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
        Dim Rng As Range, Rng2 As Range
        Dim i&, j&, r&
        With ThisWorkbook.Worksheets("Лист1")
            r = .Cells(.Rows.Count, 2).End(xlUp).Row
            Set Rng = .Range("B2:B" & r)
            i = 1
            Do While i < r - 1
                Do While Rng.Cells(i).Offset(j) = Rng.Cells(i)
                    j = j + 1
                Loop
                If j - 1 Then
                    Set rng2 = .Range(Rng.Cells(i), Rng.Cells(i).Offset(j - 1))
                    rng2.Merge
                    i = i + j
                Else
                    Set rng2 = Rng.Cells(i)
                    i = i + 1
                End If
                With rng2.Borders
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .Weight = xlMedium
                End With
            Loop
        End With
Application.DisplayAlerts = 1
End Sub