Sub SortStolb()
    r0_ = 1
    c1_ = Cells(r0_, Columns.Count).End(1).Column
    If c1_ = 1 Then Exit Sub
    For c0_ = 1 To c1_
        If Cells(r0_, c0_) <> "" Then Exit For
    Next c0_
    nc_ = c1_ - c0_ + 1
    If nc_ < 3 Then Exit Sub 'если по крайней мере 3 столбца
    ar = Cells(r0_, c0_).Resize(1, nc_)
    Set slov = CreateObject("Scripting.Dictionary")
    With slov
        For i = 1 To nc_
            .Item(ar(1, i)) = .Item(ar(1, i)) + 1
        Next i
        ff = .keys()(0)
        ark = .keys
        ari = .items
        For i = 0 To .Count - 1
            For j = 0 To .Count - 2 - i
                If ari(j) < ari(j + 1) Then
                    aaa = ari(j)
                    bbb = ark(j)
                    ari(j) = ari(j + 1)
                    ark(j) = ark(j + 1)
                    ari(j + 1) = aaa
                    ark(j + 1) = bbb
                End If
            Next j
        Next i
        r1_ = Cells(1).SpecialCells(xlLastCell).Row
        nr_ = r1_ - r0_ + 1
        Application.ScreenUpdating = 0
        Application.Calculation = xlCalculationManual
        For i = 0 To .Count - 1
            If ari(i) = 1 Then Exit For
            nn_ = 0
            ar = Cells(r0_, c0_).Resize(1, nc_)
            For k = 1 + n_ To nc_
                If ar(1, k) = ark(i) Then
                    Cells(r0_, c0_ + k - 1).Resize(nr_, 1).Cut
                    On Error Resume Next
                    Cells(r0_, c0_ + n_).Resize(nr_, 1).Insert Shift:=xlToRight
                    On Error GoTo 0
                    DoEvents
                    n_ = n_ + 1
                    nn_ = nn_ + 1
                    If nn_ = ari(i) Then Exit For
                End If
            Next k
        Next i
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = 1
    End With
    MsgBox "Всё"
End Sub