VBAでのリスト不一致抽出について

こんばんわ。
エクセルのマクロ処理なんですが、添付画像のようにＡ欄、Ｂ欄のそれぞれのリストを照合して重複していない文字を別セルに抽出したいのです。
この場合ですとＡ欄の名簿を基本としてＢ欄で重複していない文字をＢ９セルに抽出する場合のVBAコードを教えてほしいと思います。関数ではなくマクロを使用したいと思っています。
宜しくお願いします。

No.2 ベストアンサー 回答者： OrangeCake 回答日時： 2018/08/22 11:14

こんな感じはいかがでしょうか。

sheetはActiveSheetにしています。
抽出先は、B列最終データ行の2行下からになっています。

Sub 不一致抽出()

Dim Dic As Object
Dim dkey As Variant
Dim dtRow As Integer
Dim opRow As Integer

Set Dic = CreateObject("Scripting.Dictionary")

dtRow = 2 'A列データ開始行

'A列をDictionaryオブジェクトに格納
Do Until ActiveSheet.Cells(dtRow, 1).Value = ""
dkey = ActiveSheet.Cells(dtRow, 1).Value
If Not Dic.exists(dkey) Then
Dic.Add dkey, Null
End If
dtRow = dtRow + 1
Loop

dtRow = 2 'B列データ開始行
opRow = Cells(Rows.Count, 2).End(xlUp).Row + 2 'B列の最終行＋2行

'B列がDicitonaryオブジェクトにない場合はB列の下に書き出します
Do Until ActiveSheet.Cells(dtRow, 2).Value = ""
dkey = ActiveSheet.Cells(dtRow, 2).Value
If Not Dic.exists(dkey) Then
ActiveSheet.Cells(opRow, 2).Value = dkey
opRow = opRow + 1
End If
dtRow = dtRow + 1
Loop

End Sub

この回答へのお礼

回答有難うございました。
ご丁寧な解説も有難うございました。出来ました、マクロはまだ勉強し始めて間が無いので大変助かりました。

お礼日時：2018/08/22 20:30

No.5 回答者： fujillin 回答日時： 2018/08/23 11:01

No3です

少しわかりにくかったかも知れないので、補足しておきます。

No3で例示したコードの前半では対象範囲（＝A,B列）の各名前をkeyにしたDictionaryを作成しています。
値がとり得る範囲は、1、2、3のいずれかで、それぞれ以下のような意味になります。
　1：A列だけに存在する名前
　2：B列だけに存在する名前
　3：A列、B列に存在する名前

No3の例示では、値が3以外（=1と2）を抽出するようにしてありますが、これを「1を抽出」や「2を抽出」とすることによって「A列のみのチェック」、「B列のみのチェック」の処理に変えることができるという次第です。


ついでながら…
＞このコード等は fujillin 様がプログラミングされたのでしょうか？
ご質問の内容がどこかにころがっているものとは思えません。作成しています。

＞ものすごい高度ですね。
私は、見よう見まねで覚えただけなので、コーディングはほんの趣味程度です。
ですので、決して「高度なもの」は作成できませんので、誤解のなきように。

この回答へのお礼

ご丁寧に有難うございます
大変参考になって有難うございます、まだ検索等は勉強中ですので感謝しています

お礼日時：2018/08/23 21:01

No.4 回答者： めぐみん_ 回答日時： 2018/08/23 08:55

No.1です。

逆があり得ないなら、
・まずB列の値を.NET FrameworkのSystem.Collections.ArrayListに全て放り込みます。
・次にA列を調べ同じ値があったらArrayListから削除していきます。
・最後に残った値の数でメッセージボックスの表示を変えます。

Sub megu()
Dim al As Object
Dim ra As Range, rb As Range
Dim st As String

Set al = CreateObject("System.Collections.ArrayList")

For Each rb In Range("B2", Cells(Rows.Count, "B").End(xlUp))
If al.IndexOf_3(rb.Value) < 0 Then al.Add (rb.Value)
Next

For Each ra In Range("A2", Cells(Rows.Count, "A").End(xlUp))
If al.IndexOf_3(ra.Value) >= 0 Then al.Remove (ra.Value)
Next

st = ""

If al.Count = 1 Then
st = al(0)
ElseIf al.Count > 1 Then
st = Join(al.ToArray(), vbCrLf)
Else
st = "共に同じです"
End If

MsgBox st

Set al = Nothing
End Sub

ただもしかすると、
・Set al = CreateObject("System.Collections.ArrayList")
でエラー表示とかが出るなら、.NET Frameworkの古いバージョンがPCにないと思いますのでこの回答は無視して下さい。

この回答へのお礼

回答のほう有難うございます
助かりました！^q^

お礼日時：2018/08/23 21:03

No.3 回答者： fujillin 回答日時： 2018/08/22 17:25

こんにちは

＞Ａ欄、Ｂ欄のそれぞれのリストを照合して重複していない
＞文字を別セルに抽出したいのです。
文章通りの意味にとると、No1様がすでにご指摘のように、B列だけでなくA列に対してもチェックが必要になると思われます。

＞Ａ欄の名簿を基本としてＢ欄で重複していない文字を～～
だと、B列だけをチェックすれば良いものと読み取れます。


下記はとりあえず両方の列をチェックする一例ですが、不明点は以下の様に仮定しています。
・A列、B列のそれぞれ最下行（可変）までのデータを対象とする。
・A列内での重複、B列内での重複は重複とみなさない。
　（他の列と重複しているか否かで判断する）

※ 最下行までを対象としているため、結果をA、B列に表示するのは好ましいとは思えないので、ひとまずメッセージボックスに表示するようにしてあります。（複数存在する場合は改行で表示）
　どこかのセルに表示したい場合は、そのまま結果をセルに入れれば良いです。
※ B列だけチェックすれば良いのであれば、Dicの値が2のものを抽出すればよいです。
　（A列だけをチェックしたい場合は、同様に値が1のものだけを抽出）

Sub Sample()
Dim Dic As Object, k
Dim rw As Long, col As Integer
Dim s As String, res As String

Set Dic = CreateObject("Scripting.Dictionary")

For col = 1 To 2
　For rw = 2 To Cells(Rows.Count, col).End(xlUp).Row
　　s = Cells(rw, col).Value
　　If s <> "" Then
　　　If Dic.Exists(s) Then Dic.Item(s) = Dic.Item(s) Or col Else Dic.Add s, col
　　End If
　Next rw
Next col

res = ""
For Each k In Dic.Keys
　If Dic.Item(k) <> 3 Then res = res & vbNewLine & k
Next
res = Mid(res, 3)
MsgBox res

End Sub

この回答へのお礼

回答有難うございました。
>ひとまずメッセージボックスに表示するようにしてあります。（複数存在する場合は改行で表示）
これは非常に良いと思いました。
このコード等は fujillin 様がプログラミングされたのでしょうか？ものすごい高度ですね。
有難うございました

お礼日時：2018/08/22 21:12

No.1 回答者： めぐみん_ 回答日時： 2018/08/22 08:47

A欄にあってB欄に存在しないケースもあり得るのでしょうか？（今回の逆パターン）

この回答へのお礼

回答有難うございます
お返事遅れてすみません
そのケースはありません。宜しくお願いします

お礼日時：2018/08/22 20:24