Sub KolDub1()
    t_ = Timer
    With Me.UsedRange: End With
    c0_ = 5
    c_ = Cells(1).SpecialCells(xlLastCell).Column + 1
    If c_ < c0_ Then Exit Sub
    r0_ = 1
    nr_ = Cells(1).SpecialCells(xlLastCell).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 Me.Sort
        .SortFields.Add Key:=Cells(r0_, c0_ + i)
        .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 Me.UsedRange: 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")
End Sub

    With ActiveSheet.Sort
        .SortFields.Add Key:=Cells(r0_, c0_ + i)
        .SetRange Cells(r0_, c0_ + i).Resize(nr_ * (c_ - c0_))
        .Apply
    End With