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 回答日時： 2001/05/10 11:22

少し時間があったので作ってみました。

前にあった質問で回答したモジュールをかえてみました。
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での処理が続くと思われますので、また厄介なご質問をすることがあるかもしれません。その際にはどうぞお力をお貸しくださいませ。心よりお願いいたします。そして今回も素晴らしいＶＢＡを作ってくださり本当にありがとうございました。

お礼日時：2001/05/10 23:21

No.4 回答者： ranako 回答日時： 2001/05/11 10:35

もう解決されたようですが、考えてみましたので投稿します。

超簡単な方法で、笑ってしまうかも。（最大件数は変えてください）

Sub Macro1()
Dim w_cnt1, w_cnt2, w_cnt3, w_cnt4 As Integer
Dim w_buff1, w_buff2, w_buff3, w_buff4 As String
Dim w_flg As Boolean

w_cnt3 = 1
w_cnt4 = 1

For w_cnt2 = 1 To 20
w_buff2 = "A" & w_cnt2
If Sheet2.Range(w_buff2) = "" Then Exit For
For w_cnt1 = 1 To 20
w_flg = False
w_buff1 = "A" & w_cnt1
If Sheet1.Range(w_buff1) = "" Then Exit For
If Sheet1.Range(w_buff1) = Sheet2.Range(w_buff2) Then
w_buff2 = "A" & w_cnt2
w_buff3 = "A" & w_cnt3
Sheet3.Range(w_buff3) = Sheet2.Range(w_buff2)
w_buff2 = "B" & w_cnt2
w_buff3 = "B" & w_cnt3
Sheet3.Range(w_buff3) = Sheet2.Range(w_buff2)
w_buff2 = "C" & w_cnt2
w_buff3 = "C" & w_cnt3
Sheet3.Range(w_buff3) = Sheet2.Range(w_buff2)
w_cnt3 = w_cnt3 + 1
w_flg = True
Exit For
End If
Next
If w_flg = False Then
w_buff2 = "A" & w_cnt2
w_buff4 = "A" & w_cnt4
Sheet4.Range(w_buff4) = Sheet2.Range(w_buff2)
w_buff2 = "B" & w_cnt2
w_buff4 = "B" & w_cnt4
Sheet4.Range(w_buff4) = Sheet2.Range(w_buff2)
w_buff2 = "C" & w_cnt2
w_buff4 = "C" & w_cnt4
Sheet4.Range(w_buff4) = Sheet2.Range(w_buff2)
w_cnt4 = w_cnt + 1
End If
Next

End Sub

この回答へのお礼

ranakoさんご回答ありがとうございます。わざわざ考えていただきとても嬉しく思います。プログラミングにはとても興味を持っておりますので、ranakoさんのＶＢＡを実行してみました。途中でデバックが起動してしまい、残念なことに少しうまくいきませんでしたが、それはきっとranakoさんが最大件数を変えるようにと書かれているようにこちらの表の仕様とプログラムの内容が少し合致しないところがあるのだと思います。今の私の力では自力で修正できず残念です。もう少し勉強をして、こういう場合はここの値を直せばいいんだな、とすぐに修正できるようになりたいと思っております。まだまだ力不足なので、これからもどうぞよろしくお願いいたします。今回はどうもありがとうございました。

お礼日時：2001/05/11 23:45

No.3 回答者： nishi6 回答日時： 2001/05/10 23:48

お礼にお礼・・・

うまくいって良かったですね。

私は、半分くらいは息抜き、もう半分は質問に答えることで新しいことを知ることができるということがありOKWebを楽しんでいます。答えてそれを仕事に応用したこともあります。
april21さんとか私とは違った観点から問題を見ておられるなと感じることも多く、勉強になります。
思われているほど負担でもありませんし、他の回答者もたくさんいらっしゃるのでどんどん質問されてもいいと思います。頑張って下さい。

この回答へのお礼

nishi6さん、お礼にお礼なんて恐縮です。私はnishi6さんをはじめ、こういった場で、質問に答えてくださっている方々の行為には心から尊敬いたします。そして、今回のnishi6さんのご回答を読んで、このように謙虚な心持で私たちの質問に答えてくださっているのだということを知り、深く感銘を受けました。nishi6さんたちの回答でどれだけの人が、残業地獄から救われたり、学校の課題でモヤモヤしていたところが吹っ切れたり、新しい道を開拓するきっかけを与えられたりしていることでしょうか！！本当に素晴らしいことだと思います。私もこんな風に人の役に少しでも立つことが出来たら人生2倍も3倍も幸せを感じることができるだろうなぁと羨ましく思います。またnishi6さんのやさしいお言葉に甘えて面倒な質問をしてしまうかもしれませんが、どうぞこれからもよろしくお願いします。本当にありがとうございました。

お礼日時：2001/05/11 01:49

No.2 回答者： marsah 回答日時： 2001/05/10 21:40

こんばんわ。

　私はVBAは苦手なので、VBA無しで無理やりやる方法を考えてみました。　かえって面倒かもしれませんし、検証していません。(笑)

１.　sheet1 と sheet2 においてフィールドAが共通のレコードを選択

　クエリのデザインビューでsheet1とsheet2を、フィールドAで結合し、結合のプロパティは“両方のフィールドが同じ行だけを含める”とします。　選択フィールドは、sheet2.[主キーフィールド名] , sheet2.A , sheet2.B , sheet2.C , sheet2.D , ... とします。　このクエリをqueryXとします。


２.　sheet1のフィールドAにあって sheet2のフィールドAに無い値を持つレコードを選択

　データベースウィンドウでオブジェクトにクエリを選び、新規作成を押して不一致クエリウィザードを選びます。　最初にqueryXを選び、比較するものにsheet1を選びます。　このクエリをqueryYとします。


３.　queryXとqueryYをサブセット化する

　sheet1とsheet2に同じ値の主キーが含まれている可能性があるときは、どちらかのクエリに細工します。　例えば、元の主キーフィールドを非表示にして、新たなフィールドに“新主キーフィールド名: [主キーフィールド名]+10000”のようにして主キーの代わりとし、sheet1とsheet2に同じ値の主キーが含まれないようにします。


４.　queryXとqueryYを連結する

　デザインビューでクエリを作成する->テーブルやクエリを追加せず閉じる->SQLビュー とします。
SELECT [queryX].[主キー用フィールド名] , [queryX].[B] , [queryX].[C] , [queryX].[D] , ... FROM [queryX]
UNION ALL
SELECT [queryY].[主キー用フィールド名] , [queryY].[B] , [queryY].[C] , [queryY].[D] , ... FROM [queryY]
と直接入力し、queryZとします。

５.　テーブルを作成する

　新規クエリでqueryZの全フィールドを選択し、クエリの種類->テーブル作成を選択し、！を押します。

[主キーフィールド名]は該当するフィールド名に置き換えてください。　, ... の意味は、その他の必要なフィールド全てを、ということです。

無視されたデータは、２.の応用->５.で可能です。

お邪魔しました。

この回答へのお礼

marsahさん、ご回答ありがとうございます。この処理はACCESSでの処理ですね。私も以前からデータベースを使用して見たいと思っておりましたので大変参考になります。今回の質問での処理は基本的にExcelでのことを想定しておりましたので、時間をとってACCESSでも挑戦してみようと思います。実は処理するデータが大量なので、データの加工をする際にもデータベースを使用した方がいいのか、社内でも案件が出ているところなのです。データに対する処理の使用が複雑になるたびにデータベースソフトの方がいいのかなぁ等と考えてしまいますが、データが大量・処理が複雑＝データベースの方がよい、ということでもなさそうなので、安易に転換してしまっていいものかとも思っております。でも今回のmarsahさんのご回答はデータベースに挑戦してみようかな、という気持ちにさせていただきましたので、お力をお借りすることがあるかもしれません。その際にはどうぞよろしくお願いいたします。

お礼日時：2001/05/11 00:32