VBA-重複データ同士の照合

VBAで照合作業用マクロを作成しております。
初心者なのでネット検索などして作成しているのですが
重複データ同士の照合というものが見つからないため
どなたかご教示いただけると助かります。
(OS-Windows7,Office2013)

作業内容：
①シート1とシート2のデータを売上番号と金額をキーにして照合する
②データが一致したシート2の該当行(同行横)へ、シート1の該当行を転記

・シート1,2の売上番号と金額は重複を含む
・重複している売上番号等は、シート1,2で同数
・データは各シート1,000行～1,200行
・マッチング出来ないデータについては空白とする

=======================================
◆質問◆
重複データの"Item"を転記する方法
(転記は金額を基準とする)
=======================================

○シート1（明細データ)
売上番号　金額　　Item1　 Item2
--------------------------------------
44-3　　2,000　　500　　1,500
11-1　　1,000　　300　　　700
11-1　　1,000　　500　　　500
11-1　　1,500　　500　　1,000
22-4　　3,000　 2,000　　1,000

○シート2(売上データ)
売上番号　金額　　氏名
------------------------
11-1　　　1,000　　佐藤
11-1　　　1,000　　佐藤
11-1　　　1,500　　佐藤
55-2　　　4,500　　上田
22-4　　　3,000　　松本

　　↓マクロを実行

○シート2　完成表(希望)
売上番号　金額　　氏名　　Item1　 Item2
------------------------------------------------
11-1　　　1,000　　佐藤　　300　　700
11-1　　　1,500　　佐藤　　500　　500
11-1　　　1,000　　佐藤　　500　1,000
55-2　　　4,500　　上田　　　(空白)
22-4　　　3,000　　松本　2,000　1,000

==========================================
下記マクロを実行した結果：
重複番号の"Item"列が1行しか転記されない->重複最終行のみ
(ユニークの番号同士については問題なく転記される)
=============================================
Sub TEST01()

Dim sht1, sht2
Application.ScreenUpdating = False
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
d = sht1.Range("A5536").End(xlUp).Row
On Error Resume Next

For i = 2 To d
'条件設定
If sht1.Cells(i, "A") = sht2.Cells(i, "A") Then
ElseIf sht1.Cells(i, "B") = sht2.Cells(i, "B") Then
End If
If sht1.Cells(i, "C") <> sht2.Cells(i, "C") Then

'Sheet2で該当行を検索
For r = 2 To 1000
If sht1.Cells(i, "A") = sht2.Cells(r, "A") Then Exit For
Next r

'該当行をSheet2へ転記
sht2.Cells(r, "D") = sht1.Cells(i, "C")
sht2.Cells(r, "E") = sht1.Cells(i, "D")

End If
Next i
Application.ScreenUpdating = True
End Sub

どうぞよろしくお願いします。

No.1 ベストアンサー 回答者： cj_mover 回答日時： 2015/02/23 16:38

こんにちは。

んー、なんていうか、そういう処理をする場合は、
何でもかんでもＶＢＡの力技に任せるのではなくて、
ある程度、扱い易いシートデザインを用意しておくのが本筋とは思います。
例えば、実質的な主キーは、
A列とB列を連結（実戦では区切り文字を挟みます）したもの、なのですから、
予め、実質的な主キーをひとつのフィールドとして用意しておくとか、
それだけでもＶＢＡの処理は易しくなり、
ＶＢＡ側の設計も幅が出てきて易しくなります。
ＶＢＡだけでなくて全体の設計を見直した方がベターではあります。
色々事情はおありでしょうから、このことは先の話として、置いといて、
本題に直接的にお答えします。

要は、
同じ（ユニークでない）キーに対して、
複数のデータがあり、それらを、順番にピックアップして、
ひとつの表にまとめたい、ということだと理解しています。

これはこれで、'表計算'や'データベース'のアプリケーションにとっては、
例外的で苦手とする処理のひとつだったりして、
ＶＢＡ書くのも簡単ではないと思います。

とりあえず、
　★Dictionaryオブジェクト
　★Collectionオブジェクト
　★二次元配列
等、普通は初級では扱わないような手法で、
スクリプトを書くのが（私にとって）簡単な方法で一案、書いてみました。

実質的な主キーの扱いについては、
　.Cells(i, "A").Text & vbCr & .Cells(i, "B")
のように、セルには入力できない改行文字を区切り文字を使って、
A列とB列を連結しています。

実質的な主キーに対応したデータを
Dictionaryオブジェクトのアイテムに置いたCollectionオブジェクトに
追加したり削除したりして、
同じ（ユニークでない）キーに対応した複数のデータを順番に出力します。

技術的な解説は一度では難しいので省きますが、
★マークを付けたキーワードについて、調べてみて、
その上でお尋ねになりたいことがあれば、ひとつひとつお応えします。
何をどうやっても難しい要求を実現するのは、難しい、
これは仕方ないことですが、少しでもマシ（技術的により簡単）な
やり方を思いついたら、もしかしてまた回答するかもしれません。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8929559()
Dim objDict As Object　'　As Scripting.Dictionary　'
Dim sTemp As String
Dim d As Long
Dim i As Long

　　Set objDict = CreateObject("Scripting.Dictionary")　'　= New Scripting.Dictionary
　　With Worksheets("Sheet1")
　　　　d = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　For i = 2 To d
　　　　　　sTemp = .Cells(i, "A").Text & vbCr & .Cells(i, "B")
　　　　　　If VarType(objDict(sTemp)) = vbEmpty Then
　　　　　　　　Set objDict(sTemp) = New Collection
　　　　　　End If
　　　　　　objDict(sTemp).Add .Range(.Cells(i, "C"), .Cells(i, "D")).Value, CStr(objDict(sTemp).Count)
　　　　Next i
　　End With
　　Application.ScreenUpdating = False
　　With Worksheets("Sheet2")
　　　　d = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　For i = 2 To d
　　　　　　sTemp = .Cells(i, "A").Text & vbCr & .Cells(i, "B")
　　　　　　If objDict.Exists(sTemp) Then
　　　　　　　　.Range(.Cells(i, "D"), .Cells(i, "E")).Value = objDict(sTemp)(1)
　　　　　　　　objDict(sTemp).Remove 1
　　　　　　End If
　　　　Next i
　　End With
　　Application.ScreenUpdating = True
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

この回答へのお礼

丁寧なアドバイス参考になります。希望通りの表になりました。
オブジェクトと配列について調べてみましたが、基礎知識が不足しているので不明な点自体が分からないという状態です。基礎的なことをもっと学習する必要を感じています。セルの結合は全く思い浮かびませんでしたので目からウロコでした。質問して良かったです。ありがとうございました。

お礼日時：2015/02/23 23:00