nr_ = Cells(Rows.Count, 1).End(xlUp).Row - r0_ + 1

With ActiveSheetSort

With ActiveSheet.Sort

.Apply

Sub KolDub225()
    t_ = Timer
    With ActiveSheetUsedRange: End With
    c0_ = 7
    r0_ = 4
    c_ = Cells(r0_ - 1, Columns.Count).End(1).Column + 1
    If c_ < c0_ Then Exit Sub
    nr_ = Cells(Rows.Count, 1).End(3).Row - r0_ + 1
    If nr_ < 1 Then Exit Sub
    Application.ScreenUpdating = 0
    cal_ = Application.Calculation
    Application.Calculation = 3
    For i = 0 To c_ - c0_ - 1
        Cells(r0_ + nr_ * i, c_).Resize(nr_) = Cells(r0_, c0_ + i).Resize(nr_).Value
    Next i
    With ActiveSheet.Sort
        .SortFields.Add Key:=Cells(r0_, c0_ + i)
        .SetRange Cells(r0_, c0_ + i).Resize(nr_ * (c_ - c0_))
        .Apply
    End With
    n_ = Cells(Rows.Count, c0_ + i).End(3).Row
    ar = Cells(r0_, c0_ + i).Resize(n_)
    Cells(r0_, c0_ + i).Resize(n_).Clear
    With ActiveSheetUsedRange: End With
    For i = 1 To n_ - 1
        If ar(i, 1) = ar(i + 1, 1) Then
            x_ = x_ + 1
            If k_ = 0 Then
                x_ = x_ + 1
            End If
            k_ = 1
        Else
            k_ = 0
        End If
    Next i
    Application.Calculation = cal_
    Application.ScreenUpdating = 1
    Cells(1, 2) = x_
    Debug.Print "end    " & Format(Timer - t_, "0.00")
    UserForm1.Hide
End Sub

Sub Form1()
UserForm1.Show
End Sub