VBAで重複しないデータを1列縦に並べたいです。

質問

下記の様にC,E,G,Iに文字（主に地名）を入力した後にVBAでA列に重複しない文字だけ縦に並べて行きたいのですがご教授頂けませんでしょうか。
B,D,F,H,Iは備考として自由記入したいので対象外にしたいです。
説明が難しいのですがA1から横に検索し重複しない文字や数字のみA列上から詰めて転記するイメージとなります。度々入力値が変更される事もあるので実行ボタンを設置してVBAで処理出来たら助かります。どうぞ宜しくお願い致します。

A, B, C, D, E, F, G, H, I, j
111 111 222 111 333
222 111 111 222 444
333 666 555 333 777
444 999 222 333 888
666
555
777
999
888

回答No.2

kkkkkm · ベストアンサー

参照設定で以下の設定をしてから実行してください。
VBEの画面で「ツール」メニューから「参照設定」をクリックします。
「Microsoft Scripting Runtime」にチェックします。

Sub Test()
Dim mDic As New Scripting.Dictionary
Dim c As Range, mVar As Variant
Dim i As Long: i = 1

Range("A:A").ClearContents

For Each c In Range(Cells(1, "C"), Cells(Rows.Count, "I").End(xlUp))
If c.Column Mod 2 <> 0 Then
If mDic.Exists(c.Value) = False Then
mDic.Add c.Value, c.Value
End If
End If
Next
For Each mVar In mDic
Cells(i, "A").Value = mDic.Item(mVar)
i = i + 1
Next
End Sub

お礼

お早いご対応大変感謝致します
問題なく動作致しました
本当にありがとうございました

回答No.3

imogasi

すでに回答は出ているが、少し違ったやり方で。
ＣＯＵＮＴＩＦ関数利用法。
ーー
例データ
Ａ１：Ｇ１０
A, B C D F G
111 111 222 111 333 1112
222 111 111 222 444
333 666 555 333 777
444 999 222 333 888
666
555
777
999
888
ーーー
標準モジュールに
Sub test01()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
sh2.Columns("A:A").Clear

Set Rng = sh1.Range("A2").CurrentRegion
Set Rng = Rng.Offset(1, 0) '１行下から対象にする
Rng.Select
MsgBox "A" '確認のため

For Each cl In Rng
If cl <> "" Then
If WorksheetFunction.CountIf(sh2.Columns("A:A"), cl) = 0 Then
MsgBox cl '確認のため。本番では削除
lr = sh2.Range("A100000").End(xlUp).Row
sh2.Cells(lr + 1, "A") = cl
End If
End If
Next
End Sub
--
実行結果
111
222
333
1112
444
666
555
777
999
888
上記質問例＋αではＯＫのようだが、データにもっと多様性があるとき、うまくゆくとよいが。
例えばCurrentRegionが使えないデータのあり様の場合は、要修正。
あと氏名によるソートは必要かもしれないが、上記では略。

回答No.1

masnoske

重複なしのリストは縦方向でないとできません。

マクロの記録を開始。
該当データ範囲をコピー。
シートの空いた場所か、別のシートに行列入れ替えで貼り付け。
リスト化したいデータを空いた1列にコピぺ。
コピペした列から重複なしリストを作成。
作業に使った不要なセルのデータを削除。
マクロの記録終了。

記録が終わったらシートにボタンを貼り付け、記録したマクロをボタンに登録。