解決済み

エクセル2000マクロ検索方法

  • すぐに回答を!
  • 質問No.295683
  • 閲覧数82
  • ありがとう数0
  • 気になる数0
  • 回答数2
  • コメント数0

Aのファイル a.xls シート名 aaa
Bのファイル b.xls シート名 bbb

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

Bのファイルに下記のデータベースがあります。
  A列 B列
  0001 300
  0002 200
  
抽出条件方法
AのファイルとBのファイルのA列を参照して違うものだけを、Aのファイルから
別のファイルに取り出す方法をマクロでの記述方法を教えてください。

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

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

質問者が選んだベストアンサー

  • 回答No.2

ベストアンサー率 28% (4440/15781)

オフィス系ソフト カテゴリマスター
booka.xlsとbookb.xlsを\My Documentsに作らせてもらった。アウトプットファイルはbookbのsheet2に作らせてもらった。データのファイル(Book)が違うため勝手が違い多少苦労しました。booka.xlsのVBE画面に下記test01をコーディングしてください。Thisworkbookを使って切りぬけましたが、もっと良い答えが出ることを期待しつつ。小数例でテスト済です。結果も別ファイルにしたかったが、夜もふけて来て・・・。
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 '2行目からデータ。BookaのSheet1の行ポインター
j = 2 '2行目からデータ。BookbのSheet1の行ポインター
k = 2 '2行目からデータ。BookbのSheet2の行ポインター
'----
p01:
'-----終わり判定
If i > a + 1 Then GoTo p02
If j > b + 1 Then GoTo p03
'----Sheet1のキーとSheet2のキーの比較をする
'----一致する時なにもしないで、
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
'--------トランザクションなし
'-------本問題では、このケースをSheet2へ書き出す
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
感謝経済、優待交換9月20日スタート

その他の回答 (全1件)

  • 回答No.1

ベストアンサー率 68% (791/1163)

新規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
AIエージェント「あい」

こんにちは。AIエージェントの「あい」です。
あなたの悩みに、OKWAVE 3,500万件のQ&Aを分析して最適な回答をご提案します。

関連するQ&A
このやり方知ってる!同じこと困ったことある。経験を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する

特集


より良い社会へ。感謝経済プロジェクト始動

ピックアップ

ページ先頭へ