2つの表を統合するＶＢＡマクロについて（２）

質問

「2つの表を統合するＶＢＡマクロについて」での質問を補足いたしますのでどうかお力をお貸しください。
前回の質問で例にあげたsheet1の表とsheet2の表を統合してsheet3に統合表を作りたいのですが、どのように統合したいのかといいますと、

(1)それぞれの表のA列をキーに、sheet1にもsheet2にもあるデータは新たに統合する表に採用します。前回の例でいうと、sony1,2,5,7ですね。この両者共通のものは新たに統合する表には、sheet2の方のデータを採用します。（複数ある場合は全て採用します。)
(2)次にsheet1にしかないデータは統合する表に採用します。前回の例ではsony003が該当します。
(3)最後にsheet2の方にしかないデータは統合する表には採用しません。無視します。
この(1)から(3)を実行して下記のようは統合表を作成したいのです。

（sheet3 統合表）
　　A 　　B 　　C 　　　D
sony001 男　　東京　Japan　←（sheet2のデータ）
sony002 女　　埼玉　Japan　←（sheet2のデータ）
sony002 女　　千葉　U S A　←（sheet2のデータ）
sony003 女　　千葉　U S A　←（sheet1のデータ）
sony005 女　　東京　Russia　←（sheet2のデータ）
sony007 男　　東京　U S A　←（sheet2のデータ）
sony007 女　　東京　Russia　←（sheet2のデータ）

そしてできれば採用されなかった(無視されたデータ)をsheet4にリストアップしたいのです。

（sheet4 無視されたデータ）
sony004 男　　大阪　Canada
sony006 女　　東京　Russia

このような処理を自動的にできるＶＢＡマクロがわかる方がいらっしゃいましたら、どうかご教授くださいませ。データが大量なので手動ではとても時間がかかってしまい困っております。どうかお力をお貸しください。よろしくお願いいたします。

回答No.1

nishi6 · ベストアンサー

少し時間があったので作ってみました。
前にあった質問で回答したモジュールをかえてみました。
Sheet1のデータを基準にSheet2のデータを見ています。
うまく動けばいいですが。（標準モジュールに貼り付けます）

Public Sub TougouiList()
Dim rg1, rg2, rg3, rg4 As Range 'Sheet1～Sheet4の基準とするセル
Dim cot1, cot2, cot3, cot4 As Long 'Sheet1～Sheet4のカウンタ
'
Const copyCol = 3 'コピーする列数(0から)
Dim cl As Integer '列カウンタ
'
Set rg1 = Worksheets("Sheet1").Range("A1")
Set rg2 = Worksheets("Sheet2").Range("A1")
Set rg3 = Worksheets("Sheet3").Range("A1")
Set rg4 = Worksheets("Sheet4").Range("A1")
Worksheets("Sheet3").UsedRange.Clear
Worksheets("Sheet4").UsedRange.Clear
'
With rg1
While .Offset(cot1, 0) <> ""
Select Case True
Case .Offset(cot1, 0) = rg2.Offset(cot2, 0)
'Sheet1とSheet2が一致
While .Offset(cot1, 0) = rg2.Offset(cot2, 0)
For cl = 0 To copyCol
'Sheet2のAからD列をコピーする
rg3.Offset(cot3, cl) = rg2.Offset(cot2, cl)
Next
cot2 = cot2 + 1 'Sheet2を更に調べる
cot3 = cot3 + 1
Wend
cot1 = cot1 + 1
Case rg2.Offset(cot2, 0) <> "" And .Offset(cot1, 0) < rg2.Offset(cot2, 0)
'Sheet1しかない(Sheet2はある)
While rg1.Offset(cot1, 0) <> "" And .Offset(cot1, 0) < rg2.Offset(cot2, 0)
For cl = 0 To copyCol
rg3.Offset(cot3, cl) = .Offset(cot1, cl)
Next
cot1 = cot1 + 1 'Sheet1を更に調べる
cot3 = cot3 + 1
Wend
Case rg2.Offset(cot2, 0) = ""
'Sheet1しかない(Sheet2がない)
For cl = 0 To copyCol
rg3.Offset(cot3, cl) = .Offset(cot1, cl)
Next
cot1 = cot1 + 1
cot3 = cot3 + 1
Case .Offset(cot1, 0) > rg2.Offset(cot2, 0)
'Sheet2しかない
For cl = 0 To copyCol
rg4.Offset(cot4, cl) = rg2.Offset(cot2, cl)
Next
cot4 = cot4 + 1
cot2 = cot2 + 1
End Select
Wend
'Sheet2にまだデータがある場合(基準としたSheet1はデータがなくなった)
While rg2.Offset(cot2, 0) <> ""
For cl = 0 To copyCol
rg4.Offset(cot4, cl) = rg2.Offset(cot2, cl)
Next
cot4 = cot4 + 1
cot2 = cot2 + 1
Wend
End With
End Sub

お礼

nishi6さん、早々のご回答どうもありがとうございます。前回も素晴らしいＶＢＡを考えてくださり、また今回もお世話になってしまいまして恐縮しております。前回のnishi6さんのＶＢＡは現在も大活躍で、お陰様で当初の予定の5倍くらいの速さで処理が終了しそうです。今回質問させていただいたことも基本的には前回と同じような処理なのですが、処理する表の仕様が少し変わってしまって、前回のＶＢＡをそのまま実行すると少しエラーが出てしまうところがあり、ご相談させていただきました。私どもはお客様からメールで送られてくる添付ファイル(Excelファイル）に、私どもで行ったあるテスト結果データを書き込んで送り返すので、こちらで表の仕様を変えることは出来ず、このような処理の必要があるのです。テスト結果データは、私どものデータベースから抽出してExcleにExportしていますので、簡単に用意できるのですが、そのデータを、手動で書き込んでいくのは、データの数が大量でとても時間がかかってしまうのです。本日早速1000件くらいの比較的小さな表で実行し、データのズレがないか確認してみましたが、お見事です。データのズレは一つも見つからず、出来上がった統合表も私たちの希望通りのものでした。本当にありがとうございます。nishi6さんのすごさには驚嘆するばかりです。しばらくExcleでの処理が続くと思われますので、また厄介なご質問をすることがあるかもしれません。その際にはどうぞお力をお貸しくださいませ。心よりお願いいたします。そして今回も素晴らしいＶＢＡを作ってくださり本当にありがとうございました。