配列について

お世話になります。excel2013を使用しています。
シート1のA列とシート2のD列が重複しているとき
重複しているものを抽出するためのマクロを作成しました。
しかし↓だと重複していないものを抽出してしまい、おそらく同じkyにしてRemove してるのがいけないことはわかるのですが、実際にどうしたら良いのかわかりません...。
それからシート3には重複しているA列と同じ行のD列をB列に表示させたいです。
よろしくお願いします。

Sub macro1()
Dim tbl, i As Long
Dim ky

With CreateObject("Scripting.Dictionary")
'シート1のキーを作成（C列）
tbl = Sheets("sheet1").Range("A1:A300000")
For i = 2 To UBound(tbl, 1)
ky = tbl(i, 1)
If Not .Exists(ky) Then .Add ky, Empty
Next

'シート2のキーを作成（A列）
tbl = Sheets("sheet2").Range("C1:C5000")
For i = 2 To UBound(tbl, 1)
ky = tbl(i, 1)
If .Exists(ky) Then .Remove ky
Next

'シート3に重複しているものを転記
If .Count Then
i = 1
For Each ky In .Keys
i = i + 1
'※A列に重複しているものを記載したいが
'※重複していないものになってしまう…
'※B列にはシート1のA列と同じ行のD列の値を記載したい
Sheets("sheet3").Range("A" & i) = ky
Sheets("sheet3").Range("B" & i) = ky '※??
Next
End If
End Sub

No.1 ベストアンサー 回答者： tom04 回答日時： 2020/01/22 14:47

こんにちは！

画像を拝見すると、重複しているのは
「□■■」と「○●○」ですよね。

一例です。
標準モジュールにしてください。
尚、Sheet1のA列・Sheet2のC列とも重複データはない！という前提です。

Sub Sample1()
　Dim myDic1 As Object
　Dim myDic2 As Object
　Dim i As Long, lastRow As Long
　Dim wS1 As Worksheet, wS2 As Worksheet
　Dim myKey, myItem, myR

　　Set myDic1 = CreateObject("Scripting.Dictionary")
　　Set myDic2 = CreateObject("Scripting.Dictionary")
　　Set wS1 = Worksheets("Sheet1")
　　Set wS2 = Worksheets("Sheet2")
　　　With Worksheets("Sheet3")
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 1 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "B")).ClearContents
　　　　　End If
　　　　　　lastRow = wS1.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　myR = Range(wS1.Cells(2, "A"), wS1.Cells(lastRow, "D"))
　　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　　If Not myDic1.exists(myR(i, 1)) Then
　　　　　　　　　　myDic1.Add myR(i, 1), myR(i, 4)
　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　lastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　myR = Range(wS2.Cells(2, "C"), wS2.Cells(lastRow, "C"))
　　　　　　　　For i = 1 To UBound(myR, 1)
　　　　　　　　　If myDic1.exists(myR(i, 1)) Then
　　　　　　　　　　myDic2.Add myR(i, 1), myDic1(myR(i, 1))
　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　　　　myKey = myDic2.keys
　　　　　　　　　myItem = myDic2.items
　　　　　　　myR = Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, "B"))
　　　　　　　　For i = 0 To UBound(myKey)
　　　　　　　　　myR(i + 1, 1) = myKey(i)
　　　　　　　　　myR(i + 1, 2) = myItem(i)
　　　　　　　　Next i
　　　　　　　 Range(.Cells(2, "A"), .Cells(UBound(myKey) + 2, "B")) = myR
　　　　　　　Set myDic1 = Nothing
　　　　　　　Set myDic2 = Nothing
　　　　　　　.Activate
　　　End With
　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

すごいです！
これずっと一週間ぐらい出来ない出来ないと唸っていたので本当感謝です！
ありがとうございました！

お礼日時：2020/01/22 15:21

No.2 回答者： fujillin 回答日時： 2020/01/22 15:18

こんにちは

＞おそらく同じkyにしてRemove してるのがいけないことはわかるのですが、～
その通りですね。
重複しているかどうかは、Sheet2のデータについて
　If .Exists(ky)
で判定できるので、重複していたら（削除ではなく）Sheet3に書き出すという処理になるのではないでしょうか？
ただし、上記のように順次出力すると、Sheet2内でデータの重複がある時に、それがダブって出力されてしまう可能性があります。

これを省くには、
　1）ひとまず出力して、後からSheet3上で重複を削除する。
あるいは
　2)Sheet3に出力して、（その後、同じデータが重複と判断されないように）
　　Dictionaryからそのkeyを削除しておく。
といった対応をすることで、処理が可能と思います。

2）の方法で「削除」の代わりに、（現在利用していない）Dictionaryのvalue値をEmpty以外にセットしておくようなことも考えられます。
value値がEmpty以外だったら「既に出力済み」とわかるので、2回目以降は出力しないようにできますよね。

この回答へのお礼

色々勉強になります。
ありがとうございました！

お礼日時：2020/01/22 15:22