Option Explicit
'人名構造体
Type PERSON
    name As String  '名前
    count As Long   '件数
End Type
 
Public Sub 並べ替え()
    Dim persons() As PERSON     '人名テーブル（可変）
    Dim dicT As Object          '連想配列 キー：人名 値：シリアル番号
    Dim seqNo As Long: seqNo = 0    '通番
    Dim ws As Worksheet         '処理対象シート
    Dim lastrow As Long         '最終行
    Dim wrow As Long            '作業用行
    Dim name As String          '名前
    Dim count As Long           '件数
    Dim i As Long
    Dim j As Long
    Set dicT = CreateObject("Scripting.Dictionary")     ' 連想配列の定義
    Set ws = ActiveSheet                                'アクティブシートを処理対象とする
    lastrow = ws.Cells(Rows.count, "K").End(xlUp).Row   'K列の最終行取得
    'K列の2行以降を読み込む
    For wrow = 2 To lastrow
        name = ws.Cells(wrow, "K").Value
        If dicT.exists(name) = False Then
            '最初に出現した名前の場合
            '人名テーブルに登録
            i = seqNo
            ReDim Preserve persons(i)
            persons(i).name = name
            persons(i).count = 1
            'テーブル添え字を連想配列に登録
            dicT(name) = seqNo
            seqNo = seqNo + 1
        Else
            '2回目以降の出現の場合
            'その名前のシリアル番号取得
            i = dicT(name)
            '件数に１加算
            persons(i).count = persons(i).count + 1
        End If
    Next
    '人名テーブルをK列へ出力する
    wrow = 2
    For i = 0 To seqNo - 1
        '当該添え字の名前と件数を取得
        name = persons(i).name
        count = persons(i).count
        '名前を件数分書き込む
        For j = 1 To count
            ws.Cells(wrow, "K").Value = name
            wrow = wrow + 1
        Next
    Next
    MsgBox ("完了")
End Sub