excel2000マクロ抽出方法

質問

2つのファイルがあります。ブック名A.XLS　シート名 WORK
　　　　　　　　　　　　 ブック名b.XLS　シート名 SORT　　　　　　　　　　　　　

ブック名A.XLS　シート名 WORKに下記のデータが入っています。

AD 1300G A227550 000PA505（Ｃ列2行目） 200112(Ｆ列)200201(Ｇ列)200202(Ｈ列）200203(Ｉ列)200204(J列)200205(Ｋ列)→1行目固定データ
AD 1300G A227550 000PA533（Ｃ列3行目）　　

ブック名b.XLS　シート名 SORTに下記のデータが入っています。

AD 1300G A227550 000PA505(A列2行目）200112(E列)200201(F列)200202(G列）200203(H列)200204(I列)200205(J列) →1行目Ｅ列～Ｊ列のデータは都度変わっている

AD 1300G A227550 000PA533(A列3行目）

　　　データ抽出条件
　ブック名A.XLS　シート名 WORKの Ｆ列～Ｋ列の1行目の列データとブック名b.XLS　シート名 SORTの
　Ｅ列～Ｊ列の1行目の列データが同じで、ブック名A.XLS　シート名 WORKのＣ列の2行目以降のコードと
　ブック名b.XLS　シート名 SORTのＡ列の2行目以降のコードが同じだったら
　ブック名b.XLS　シート名 WORKの Ｅ列～Ｊ列の同じ行にデータを入れる。違うときは、
　ブック名b.XLS　シート名 WORKのデータはそのままにする。

上記の条件を満たしたマクロの記述の仕方を教えてください。

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

回答No.1

nishi6 · ベストアンサー

質問の意味を完全に理解できない状態での回答です。モデル的な処理にしているつもりです。実情に合うように修正してみてください。

＞1行目
『1行目』という記載がありますが、質問では２行目の横に書いてある？
ブックAとブックBで1行目が異なれば、何もしない？何を意味するのだろう？

＞シート名WORKのＣ列の2行目以降のコードと・・・A列の2行目以降のコードが同じだったら・・・
シート名WORKのＣ列の値をA列の2行目と照合すればいい？複数は合致しない？

＞・・・同じだったら・・・同じ行にデータを入れる。・・・
『同じ行』とは何と同じ行？（不明なので、下ではB.xlsのSORTとWORKを2回検索しています）
『データを入れる』の『データ』とは何？(下ではA.xlsの検索している行のF～K列のデータを転記)

＞ブック名b.xls シート名WORK・・・
ブック名A.xls シート名WORK←→ブック名b.xls シート名SORT の照合を行い、
ブック名b.xls シート名WORK　に(何か)データを書き込むらしいが、
ブック名A.xls シート名WORK←→ブック名b.xls シート名WORK の照合を行い、
ブック名b.xls シート名WORK に書き込めば、ブック名b.xls シート名SORTは不要な気がするが・・・

質問の通りに書いたつもりです、理解できてない箇所があると思いますので、修正してみてください。
基本的な流れは多分、同じではないでしょうか

ここから(ブック名A.xlsの標準モジュールに貼り付け)
↓
Sub Abook_copy_ToBbook()
　　'ブック、シートの定義
　　'=== ブックA ===
　　Dim c As Integer, r As Integer 'カウンタ
　　Dim wbA As Workbook 'ブックA
　　Dim wsWORKa As Worksheet 'シートWORK
　　Dim keyA(6) As Variant '照合キー
　　Dim maxRowA As Long '最終行
　　　　Set wbA = Workbooks("A.xls")
　　　　Set wsWORKa = wbA.Worksheets("WORK")
　　　　For c = 1 To 6
　　　　　　keyA(c) = wsWORKa.Range("F1").Cells(1, c)
　　　　Next
　　'=== ブックB ===
　　Dim wbB As Workbook 'ブックB
　　Dim wsSORT As Worksheet 'シートSORT
　　Dim wsWORKb As Worksheet 'シートWORK
　　Dim keyB(6) As Variant '照合キー
　　Dim maxRowBsort As Long '最終行(シートSORT)
　　Dim maxRowBwork As Long '最終行(シートWORK)
　　　　Set wbB = Workbooks("B.xls")
　　　　Set wsSORT = wbB.Worksheets("SORT")
　　　　Set wsWORKb = wbB.Worksheets("WORK")
　　　　For c = 1 To 6
　　　　　　keyB(c) = wsSORT.Range("E1").Cells(1, c)
　　　　Next

　　'照合キーの付け合せ
　　For c = 1 To 6
　　　　If keyA(c) <> keyB(c) Then
　　　　　　Exit Sub '1行目が1つでも違っていたら何もしない
　　　　End If
　　Next

　　'最終行を決める
　　maxRowA = wsWORKa.Range("C65536").End(xlUp).Row
　　maxRowBsort = wsSORT.Range("A65536").End(xlUp).Row
　　maxRowBwork = wsWORKb.Range("A65536").End(xlUp).Row

　　'セル同士を照合するための設定
　　Dim FindAreaBsort As Range 'ブックBの照合する範囲(シートSORT)
　　Dim FindAreaBwork As Range 'ブックBの照合する範囲(シートWORK)
　　Dim fCellsort As Range 'ブックAと同じブックBのセル(シートSORT)
　　Dim fCellwork As Range 'ブックAと同じブックBのセル(シートWORK)
　　Dim matchV As Variant '照合する値
　　Set FindAreaBsort = wsSORT.Range("A2:A" & maxRowBsort)
　　Set FindAreaBwork = wsWORKb.Range("A2:A" & maxRowBwork)

　　'ブックAのC列を基準にブックBを検索する
　　For r = 2 To maxRowA
　　　　'検索する値
　　　　matchV = wsWORKa.Range("C" & r)
　　　　'検索
　　　　Set fCellsort = FindAreaBsort.Find(What:=matchV, LookAt:=xlWhole)
　　　　'一致するセルが見つかったら
　　　　If Not fCellsort Is Nothing Then
　　　　　　Set fCellwork = FindAreaBwork.Find(What:=matchV, LookAt:=xlWhole)
　　　　　　'当然、存在するだろうが安全を見てIFで判定
　　　　　　If Not fCellwork Is Nothing Then
　　　　　　　　'ブックBのEn～Jn列にブックAのF1～K1の値を書く
　　　　　　　　For c = 1 To 6
　　　　　　　　　　fCellwork.Offset(0, 3 + c) = wsWORKa.Range("C" & r).Offset(0, c + 2)
　　　　　　　　Next
　　　　　　End If
　　　　End If
　　Next

　　MsgBox "終了しました"
End Sub