【マクロ】テーブルから特定列を抽出単一化し昇順で並べる

下記の場合、テーブル1シートのG列の値を単一化しながら抽出シートのA2へ書き出し
昇順に並び替える(但し、フリガナ情報が無いと並ばないので注意)。
マクロ等でコピペ等を繰り返すと、フリガナ情報が消える場合がある。
原因は不明・・・。

抽出された値をリストで返し絞り込み用として使用している。

参照：【マクロ】オートフィルター

✦集計シートの値でテーブル1をフィルターかける。

Sub shi()

Application.ScreenUpdating = False

Application.EnableEvents = False

'Worksheets("抽出用").Visible = True

Worksheets("抽出用").Select

Range("A2:A50").ClearContents

    'オートフィルタが設定されていれば解除

    Worksheets("テーブル1").Select

    Range("A1").Select 'テーブル上にカーソルが無いと解除出来ない

    With Worksheets("テーブル1")

        If .FilterMode = True Then

            .ShowAllData

        End If

    End With

            '市を抽出し単一化する

            Dim she1, she2, she3 As Worksheet

            

            Set she1 = Worksheets("テーブル1")

            Set she2 = Worksheets("抽出用")

            Set she3 = Worksheets("集計")

            

            

            '市を単一化する

            Worksheets("テーブル1").Select

            Dim Dic, i As Long, buf As String, Keys

            Set Dic = CreateObject("Scripting.Dictionary")

                On Error Resume Next

                    For i = 2 To 50000

                    With Cells(i, 7)'単一化したい列

                    buf = .Value & " " & .Phonetic.Text '7列目を処理

                    End With

                    Dic.Add buf, buf

            Next i

                    '出力

                    Worksheets("抽出用").Select

                    Keys = Dic.Keys

                    For i = 0 To Dic.Count - 1

                        With Worksheets("抽出用").Cells(i + 2, 1) '1列目に書き出し

                        .Value = Split(Keys(i), " ")(0)

                        .Phonetic.Text = Split(Keys(i), " ")(1)

                        End With

            Next i

            Set Dic = Nothing

            '1列目を並び替え

            Worksheets("抽出用").Select

            Worksheets("抽出用").Range(Cells(2, 1), Cells(500, 1)) _

            .Sort Key1:=Worksheets("抽出用").Cells(1, 1), order1:=xlAscending

she3.Select

Range("D4:F4").ClearContents

Range("C4").Select

'Worksheets("抽出用").Visible = False

Application.CutCopyMode = False

Application.ScreenUpdating = True

Application.EnableEvents = True

End Sub