■

http://q.hatena.ne.jp/1299162578

ソートの質問で意外と難題で他にいい方法もありそうだけど、
とりあえずある程度の物はできたので置いておきます。
ただし、半角カタカナとかがまだ不完全な感じがします。

Sub mySort()
    Application.ScreenUpdating = False
    Const key As Integer = 1
    Dim rng As Range
    Dim i As Long
    Dim j As Long
    Dim moji As Integer
    Dim str As String
    Dim sc As Long
    Dim sr As Long
    Dim f As Boolean
    Dim f1 As Boolean
    
    sc = Selection.Column
    sr = Selection.Row
  
    If Selection.Columns.count < key Then
        MsgBox "キー列が不正です"
        Exit Sub
    End If
    
    If Selection.Rows.count < 2 Then Exit Sub

    Call SubSort(Selection, key, 1)
    moji = 2
    
    Do
        f = False
        f1 = False
        Set rng = Range(Cells(sr, sc), Cells(sr, sc + Selection.Columns.count - 1))
        str = StrConv(Left(Cells(sr, sc + key - 1).Value, moji - 1), vbWide)
        For i = sr + 1 To sr + Selection.Rows.count - 1
            If Len(Cells(i, sc + key - 1)) >= moji Then
                f1 = True
            End If
            
            If str <> StrConv(Left(Cells(i, sc + key - 1).Value, moji - 1), vbWide) Then
                If rng.Rows.count > 1 And f1 Then
                    Call SubSort(rng, key, moji)
                    f = True
                End If
                f1 = False
                str = StrConv(Left(Cells(i, sc + key - 1).Value, moji - 1), vbWide)
                Set rng = Range(Cells(i, sc), Cells(i, sc + Selection.Columns.count - 1))
            Else
                Set rng = Union(rng, Range(Cells(i, sc), Cells(i, sc + Selection.Columns.count - 1)))
                If i = sr + Selection.Rows.count - 1 And f1 Then
                    Call SubSort(rng, key, moji)
                    f = True
                End If
            End If
        Next i
        
        moji = moji + 1
    Loop Until Not f
    
    Application.ScreenUpdating = True
End Sub

Sub SubSort(rng As Range, key As Integer, moji As Integer)
    Dim i As Long
    Dim j As Long
    Dim lastRow As Long
    Dim sc As Long
    Dim sr As Long
    
    sc = rng.Column
    sr = rng.Row
    
    rng.Sort key1:=Cells(sr, sc + key - 1), order1:=xlAscending
    If Cells(sr + rng.Rows.count - 1, sc + key - 1).Value <> "" Then
        lastRow = sr + rng.Rows.count - 1
    Else
        lastRow = Cells(sr + rng.Rows.count - 1, sc + key - 1).End(xlUp).Row
    End If
    
    j = sr
    For i = sr To lastRow
        If Len(Cells(j, sc + key - 1).Value) >= moji Then
            If Mid(Cells(j, sc + key - 1).Value, moji, 1) Like "[ア-ン]" Or Mid(Cells(j, sc + key - 1).Value, moji, 1) Like "[ｱ-ﾝ]" Then
                Range(Cells(j, sc), Cells(j, sc + Selection.Columns.count - 1)).Cut
                Range(Cells(lastRow + 1, sc), Cells(lastRow + 1, sc + Selection.Columns.count - 1)).Insert Shift:=xlDown
            Else
                j = j + 1
            End If
        Else
            j = j + 1
        End If
    Next
End Sub