Excel VBA ある範囲内で検索条件に一致したデータを入力する

質問

Excel VBA　ある範囲内で検索条件に一致したデータを入力する

Excel2003を使用しています。
Sheet2で選択している範囲内のB列のデータがSheet1で選択している範囲内のB列のデータと一致していたら、そのA列のデータをSheet2のA列に入力するというマクロを作成中ですが、うまくいきません…。
Sheet1とSheet2の選択範囲については、このマクロを実行前に都度選択するようにし、A列のデータは日付、B列のデータは数値です。

以前、示していただいたサンプルを参考にコードを書き換えて試していますが、なかなか思うようにいかず、質問させていただきました。
よろしくお願いします。

回答No.5

noname#130090 · ベストアンサー

空欄を回避するシステムが仇になってますね。
乗りかかった船なので、これでどうでしょう？

Sub all_check()
　　Dim i As Integer, j As Integer
　　For i = 0 To Sheets(1).Range("B65536").End(xlUp).Row - 1
　　　　For j = 0 To Sheets(2).Range("B65536").End(xlUp).Row - 1
　　　　　　If Sheets(1).Range("B1").Offset(i) = _
　　　　　　　　　　Sheets(2).Range("B1").Offset(j) Then
　　　　　　　　Sheets(2).Range("A1").Offset(j) = Sheets(1).Range("A1").Offset(i)
　　　　　　End If
　　　　Next j
　　next i
End Sub

お礼

zen_kuukai さま、お礼が遅くなり申し訳ありません。
教えていただいたコードを参考にさせていただき、無事完成しました！
最後までお付き合いくださいまして、ありがとうございました。

回答No.4

noname#130090

ああ、動いて一安心です。

＞ひとつ確認というか質問ですが、このコードは選択範囲内の1番上の行は、
＞それぞれのSheetの1行目(行番号1)ということですよね。

その通りです。まず、

　　Do While Sheets(1).Range("B1").Offset(i) <> 0
　　　　i = i + 1
　　Loop

で、第1シートのB1から1つずつチェックしながらOffset(i)で下に移動します。
これでセルが「""」つまりなにも入力されていなければ止まります。
（よって、B1になにも入力されていなければ動きません）

こんどは上記のLoop文の中に

　　　　For j = 0 To Sheets(2).Range("B65536").End(xlUp).Row - 1
　　　　　　　　If Sheets(2).Range("B1").Offset(j) = "" Then Exit Do
　　　　Next j

のFor文で第2シートのB1から下に検索していきます。
これもセルが「""」（なにも入力されていない）なら止まります。

で、第1シートのB行のあるセルと第2シートのB行のあるセルが同じだったら
第1シートのB行の左隣（つまりA）のセルの値を第2シートの左隣に書き出してね。

という動きです。

なので、「Sheets(1).Range("B1")」をすべて第1シートの最初のB行セル
でもって、「Sheets(2).Range("B1")」をすべて第2シートの最初のB行セル
と書き換えれば（例: 第1シートのB4が最初ならSheets(1).Range("B4")）

動くはず。たぶん。

お礼

zen_kuukai さま、何度もありがとうございます。

手直ししてくださったコードの私なりの解釈が間違っていなかったようで良かったです。
実際に使用するデータで、使えるコードになるよう、選択範囲の最上行を取得して実行してみたところ、希望通り動作しました。

選択範囲のパターンをいくつか試していたら、Sheet1で範囲を選択する際、B列に空欄が含まれる場合があることがあり(ページをまたがっているときなのですが)、Sheet1の選択範囲の最下行も取得して、下記のようにしてみましたが、うまくいきません。

Do While Sheets(1).Cells(r1, 2).Offset(i) <> Sheets(1).Cells(r2, 2)
(r1は選択範囲の最上行、r2は選択範囲の最下行です)

何度も恐れ入りますが、ここがクリアできれば完成しそうなので、もう少しお付き合い願えないでしょうか？
よろしくお願いします。

回答No.3

noname#130090

すみません。
親切で入れたつもりのExitが間違った動きをしていました。
これで動くと思われます。というか、動きました。

Sub all_check()
　　Dim i As Integer, j As Integer
　　Do While Sheets(1).Range("B1").Offset(i) <> 0
　　　　For j = 0 To Sheets(2).Range("B65536").End(xlUp).Row - 1
　　　　　　If Sheets(1).Range("B1").Offset(i) = _
　　　　　　　　　　Sheets(2).Range("B1").Offset(j) Then
　　　　　　　　If Sheets(2).Range("B1").Offset(j) = "" Then Exit Do
　　　　　　　　Sheets(2).Range("A1").Offset(j) = Sheets(1).Range("A1").Offset(i)
　　　　　　End If
　　　　Next j
　　　　i = i + 1
　　Loop
End Sub

混乱させてしまい申し訳ない。

お礼

zen_kuukai さま、再度の回答ありがとうございます。

早速、試してみたところ、無事動作しました。
ひとつ確認というか質問ですが、このコードは選択範囲内の1番上の行は、それぞれのSheetの1行目(行番号1)ということですよね。
実際に使用するデータで実行してみたときは、前回と同じく何も変化が起きなかったのですが、Sheet1とSheet2の選択範囲の最上行を1行目に合わせて実行してみると、希望通りの結果となりました。

今回の質問では、Sheet1、Sheet2ともに、選択範囲の最上行も最下行もバラバラですので、教えていただいたコードを参考にさせていただきながら、少し手を加えてみたいと思います。

回答No.2

noname#130090

すでに回答がついていますが、
こうじゃないかなあと思ったので

Sub all_check()
　　Dim i As Integer, j As Integer
　　Do While Sheets(1).Range("B1").Offset(i) <> 0
　　　　For j = 0 To Sheets(2).Range("B1").End(xlDown).Row - 1
　　　　　　If Sheets(1).Range("B1").Offset(i) = Sheets(2).Range("B1").Offset(j) Then
　　　　　　　　if sheets(2).Range("A1").Offset(j) then Exit For
　　　　　　　　Sheets(2).Range("A1").Offset(j) = Sheets(1).Range("A1").Offset(i)
　　　　　　End If
　　　　Next j
　　　　i = i + 1
　　Loop
End Sub

ただsheet1のB列に同じ数字が2個以上あると
一番下に出たA列の数字しか反映しませんが。
1番目の回答の方で十分でしたら読み飛ばしてください。

お礼

zen_kuukai さま、回答ありがとうございます。

教えていただいたコードで試してみましたところ、エラーメッセージ等は表示されないものの、何も変化が起きませんでした。

＞ただsheet1のB列に同じ数字が2個以上あると
＞一番下に出たA列の数字しか反映しませんが。

これ(上矢印)に関しては、Sheet1の選択範囲内でB列に同じ数字が2個以上あることはないので、全く問題なかったのですが…。

記載していただいたコードでテスト後、投稿してくださったようですが、もしよろしければ、Sheet1とSheet2の範囲選択をどのようにされていたかを教えていただけないでしょうか？
エラーメッセージでも表示されれば、何かしらのヒントを得られそうなのですが、マクロを実行しても何も変化が起きないので、早速行き詰っています。

回答No.1

Yosha

前のサンプルがどういったものか分からないので、ごく平凡に。
但し、データ範囲および比較するセルの行番は、sheet1、sheet2 共に同じ１～１５行であるとします。

Sub test()
　Dim r As Integer, c As Integer
　Dim n As Integer, n1 As Integer, n2 As Integer

　Sheets("sheet2").Select
　c = 2
　For n = 1 To 15
　　r = n
　　n2 = Cells(r, c).Value
　　n1 = Sheets(1).Cells(r, c).Value
　　If n2 = n1 Then
　　　Cells(r, c-1).Value = Sheets("sheet1").Cells(r, c - 1).Value
　　End If
　Next
End Sub

で、試してみてください。

For … Next 文で、変数に n を設定し、行番 r を定義しているのは、シート１,２の各選択範囲が違ったときに、ここでそれぞれの行番を定義すれば (cf. r1 = n + 1、r2 = n + 5 のように) よいので、拡張用にと思ってこの様にしました。

お礼

Yosha さま、回答ありがとうございます。

Sheet1、Sheet2ともに選択範囲(行番号)が同じである場合のコードを教えていただきましたが、今回の質問に関しては、行番号が同じになることはほぼありませんので、回答文の最後に記載されている応用方法で試してみたいと思います。

ありがとうございました。