VBAで重複データは最後のみ反映し並び替え

質問

下記の様にE,F,G,H,I,J,K,L,M,Nに文字（主に地名）を入力した後VBAで横に検索していきA列に重複は最後の文字を抽出し縦に並べて行きたいのですがご教授頂けませんでしょうか。
説明が難しいのですがE5から横に検索し重複する文字は最後のみ反映し空白のセルは反映させずA1上から詰めて転記するイメージとなります。度々入力値が変更される事もあるので実行ボタンを設置してVBAで処理出来たら助かります。どうぞ宜しくお願い致します。（下記イメージです）

E　　F　G　H　　I　　J　　K　　L　　M　　N
111 111 222 111 333　111　　　　222
222 111 111 222 444
333 666 555 333 777
444 999 222 333 888 888
666 　　999 333 333 666
555 666 666 666
⇓
A
111
777
444
222
888
999
333
555
666

回答No.2

kkkkkm · ベストアンサー

No1です。
> A列に重複は最後の文字を抽出し
これの事を考えていませんでした。こちらに変更してください。

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

Sub Test2()
Dim mDic As New Scripting.Dictionary
Dim c As Range, mVar As Variant
Dim i As Long, j As Long: i = 0
Dim LastRow As Long, tmp As Variant

Range("A:A").ClearContents
With Range("E1")
LastRow = .CurrentRegion(.CurrentRegion.Count).Row
ReDim tmp(0 To .CurrentRegion.Count)
End With

For Each c In Range(Cells(1, "E"), Cells(LastRow, "N"))
If c.Value <> "" Then
tmp(i) = c.Value
i = i + 1
End If
Next
For i = UBound(tmp) To LBound(tmp) Step -1
If mDic.Exists(tmp(i)) = False Then
mDic.Add tmp(i), tmp(i)
End If
Next
j = mDic.Count
For Each mVar In mDic
Cells(j, "A").Value = mDic.Item(mVar)
j = j - 1
Next
End Sub

お礼

お早い対応ありがとうございます！助かりました。
修正まで頂いて感謝しております。
本当にありがとうございました！

回答No.5

kkkkkm

No3さん　わかりました。
文字は最後のみ反映し
を考えたらということですね。No1はそのことを考えていませんでした。

回答No.4

kkkkkm

No3さん　「すべき」というその根拠を教えてください。

回答No.3

f272

#1さんの書いているコードは
If mDic.Exists(c.Value) = False And c.Value <> "" Then
mDic.Add c.Value, c.Value
End If
のところを
If c.Value <> "" Then
If mDic.Exists(c.Value) = True Then mDic.Remove c.Value
mDic.Add c.Value, c.Value
End If
にすべきじゃないのかなあ。

回答No.1

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
Dim LastRow As Long

Range("A:A").ClearContents
With Range("E1")
LastRow = .CurrentRegion(.CurrentRegion.Count).Row
End With
For Each c In Range(Cells(1, "E"), Cells(LastRow, "N"))
If mDic.Exists(c.Value) = False And c.Value <> "" Then
mDic.Add c.Value, c.Value
End If
Next
For Each mVar In mDic
Cells(i, "A").Value = mDic.Item(mVar)
i = i + 1
Next
End Sub

補足

kkkkkmさま
ご親切にお早いご対応ありがとうございます！大変感謝しております。
私の説明が下手で分かり難くすみません
殆ど思い通りに動くのですが重複する物は順番的に最後のみ反映させ
途中は無い物として詰めたいと思ってます。
度々すみませんがご検討宜しくお願い致します。