エクセル２０００マクロ検索方法

質問

Ａのファイル　a.xls シート名 aaa
Ｂのファイル　b.xls シート名 bbb

Ａのファイルに下記のデータベースがあります。
　　Ａ列　Ｂ列
　　0001　100
　　0002　200
　　0004 300

Ｂのファイルに下記のデータベースがあります。
　　Ａ列　Ｂ列
　　0001　300
　　0002　200

抽出条件方法
ＡのファイルとＢのファイルのＡ列を参照して違うものだけを、Ａのファイルから
別のファイルに取り出す方法をマクロでの記述方法を教えてください。

別のファイルに取り出すデータは、下記の通リです。
　　Ａ列　Ｂ列
　　0004 300

以上よろしくお願いします。

回答No.2

imogasi · ベストアンサー

booka.xlsとbookb.xlsを\My Documentsに作らせてもらった。アウトプットファイルはbookbのsheet2に作らせてもらった。データのファイル（Ｂｏｏｋ）が違うため勝手が違い多少苦労しました。booka.xlsのＶＢＥ画面に下記test01をコーディングしてください。Ｔｈｉｓｗｏｒｋｂｏｏｋを使って切りぬけましたが、もっと良い答えが出ることを期待しつつ。小数例でテスト済です。結果も別ファイルにしたかったが、夜もふけて来て・・・。
Sub test01()
'----最下行数を得る
Workbooks.Open "c:\My Documents\bookb.xls"
a = ThisWorkbook.Worksheets("sheet1").Range("a2").CurrentRegion.Rows.Count
b = Worksheets("sheet1").Range("a2").CurrentRegion.Rows.Count
'-----ポインターを初期設定
i = 2 '２行目からデータ。BookaのＳｈｅｅｔ1の行ポインター
j = 2 '２行目からデータ。BookbのＳｈｅｅｔ1の行ポインター
k = 2 '２行目からデータ。BookbのＳｈｅｅｔ2の行ポインター
'----
p01:
'-----終わり判定
If i > a + 1 Then GoTo p02
If j > b + 1 Then GoTo p03
'----Ｓｈｅｅｔ１のキーとＳｈｅｅｔ２のキーの比較をする
'----一致する時なにもしないで、
Comp:
If ThisWorkbook.Worksheets("sheet1").Cells(i, 1) = Worksheets("sheet1").Cells(j, 1) Then GoTo Equal
If ThisWorkbook.Worksheets("sheet1").Cells(i, 1) > Worksheets("sheet1").Cells(j, 1) Then GoTo High
If ThisWorkbook.Worksheets("sheet1").Cells(i, 1) < Worksheets("sheet1").Cells(j, 1) Then GoTo Low
'--------マスターとトランザクションあり。何もしない。
Equal:
i = i + 1 'マスターとトランザクションを進める
j = j + 1
GoTo p01
'-------- マスターなし。新規トランザクション・新顔
'------本問題ではこのケース無しとしていると見える。
High:
j = j + 1
GoTo p01
'--------トランザクションなし
'-------本問題では、このケースをＳｈｅｅｔ2へ書き出す
Low:
MsgBox ThisWorkbook.Worksheets("sheet1").Cells(i, 2)
ThisWorkbook.Worksheets("sheet2").Cells(k, 1) = ThisWorkbook.Worksheets("sheet1").Cells(i, 1)
ThisWorkbook.Worksheets("sheet2").Cells(k, 2) = ThisWorkbook.Worksheets("sheet1").Cells(i, 2)
i = i + 1 'マスターを進める
k = k + 1
GoTo p01
'-------マスターの終わり
p02:
For l = i To a
ThisWorkbook.Worksheets("sheet2").Cells(k, 1) = Worksheets("sheet1").Cells(l, 1)
ThisWorkbook.Worksheets("sheet2").Cells(k, 2) = Worksheets("sheet1").Cells(l, 2)
k = k + 1
Next l
ThisWorkbook.Close
End
'------本問題では起こり得ないと仮定
p03:
End
End Sub

回答No.1

nishi6

新規Bookを作り、標準モジュールに下記コードを貼り付けます。
『a.xls』と『b.xls』を開いた状態で『a_b_Hikaku』を実行します。
新規BookのSheet1のA、B列に一致しないものを表示します。

『a.xls』から『b.xls』を見る
『b.xls』から『a.xls』を見る　の両方を行っています。ご参考に。(Excel2000で確認)

ここから
↓
Sub a_b_Hikaku()
　　Dim wbA As Workbook 'Book-a
　　Dim wsA As Worksheet 'Book-aのシートaaa
　　Dim wbB As Workbook 'Book-b
　　Dim wsB As Worksheet 'Book-bのシートbbb
　　　　Set wbA = Workbooks("a.xls")
　　　　Set wsA = wbA.Worksheets("aaa")
　　　　Set wbB = Workbooks("b.xls")
　　　　Set wsB = wbB.Worksheets("bbb")

　　Dim rowMaxA As Long 'Book-aのシートaaaの最終行
　　Dim rowMaxB As Long 'Book-bのシートbbbの最終行
　　Dim fndCell As Range '見つけたセル
　　Dim rwF As Long '見つけたセルの行
　　Dim rwW As Long '書き出す行数
　　　　rowMaxA = wsA.Range("A65536").End(xlUp).Row
　　　　rowMaxB = wsB.Range("A65536").End(xlUp).Row

　　'書き出し場所をクリア
　　Worksheets("Sheet1").Range("A:B").ClearContents
　　'Book-aからBook-bを見る
　　For rwF = 1 To rowMaxA
　　　　Set fndCell = wsB.Range("A:A").Find(wsA.Cells(rwF, 1), LookAt:=xlWhole)
　　　　If fndCell Is Nothing Then
　　　　　　rwW = rwW + 1
　　　　　　Cells(rwW, 1) = wsA.Cells(rwF, 1)
　　　　　　Cells(rwW, 2) = wsA.Cells(rwF, 2)
　　　　End If
　　Next
　　'Book-bからBook-aを見る
　　For rwF = 1 To rowMaxB
　　　　Set fndCell = wsA.Range("A:A").Find(wsB.Cells(rwF, 1), LookAt:=xlWhole)
　　　　If fndCell Is Nothing Then
　　　　　　rwW = rwW + 1
　　　　　　Cells(rwW, 1) = wsB.Cells(rwF, 1)
　　　　　　Cells(rwW, 2) = wsB.Cells(rwF, 2)
　　　　End If
　　Next
End Sub