Excel_VBAで検索してデータ反映ができない

質問

Excel関数(vlookup)ではなく、VBAで以下内容のことを作成してみたのですが、うまく動きませんでした。
どこが問題なのか調べられないため、問題個所を教えていただけます様、お願いいたします。

※Excel関数(vlookup)を使用しない理由は、検索行数が膨大で関数だと動きが重たくなるため。

お手数おかけしますが、ご教示のほど、お願いいたします。

【内容】
sheet2のB列の値をsheet1のC列へ反映したい。
なお、sheet1のA列には空白があっても空白行は飛ばして、次の行を検索・反映させる。

＜sheet1＞ ＜sheet2＞
　　A　　　B　　　C　　　　　　　　　A　　　B　　　
1　AAA　　3/2　　　　　　　　　　1 AAA　　大阪
2　BBB　　6/7 　　　　　　　　　 2　BBB　　兵庫
3　CCC　 5/31　　　　　　　　　 3　CCC　 奈良
4　DDD 7/28　　　　　　　　　 4　DDD　　和歌山
5　　　　　　　　　　　　　　　　5　EEE　　京都
6　FFF　　12/2　　　　　　　　　6　FFF　　滋賀

【作成したVBA】

Sub kensaku()

Dim search As String
Dim i As Long
Dim j As Long
For j = 3 To 10
'ｊが３からSTEPしないのはなぜか？
search = Cells(j, 2)
For i = 2 To 11
For k = 3 To 12
　　　 If search = Worksheets("sheet2").Cells(i, 1) Then
　　　　Cells(k, 3) = Worksheets("sheet2").Cells(i, 2)
End If
Next
Next
Next
End Sub

回答No.3

kagakusuki

>問題個所を教えていただけます様、お願いいたします。

　まず、

search = Cells(j, 2)

となっている事が原因の1つです。
　Cells(j, 2)とは、「2列目のj行目のセル」の事なのですから、

search = Cells(j, 2)

の箇所において変数search に格納しているのはA列のデータではなく、B列に入力されている日付のデータを格納している事になります。
　sheet2のA列には「sheet1の"B"列に入力されている日付」と同じ値が入力されているセルは存在していないため、

search = Worksheets("sheet2").Cells(i, 1)

の条件が満たされる事もない訳ですから、sheet1のC列に値が入力され無くなってしまっている訳です。
　上手く行かない原因のもう1つは

For k = 3 To 12
　　　 If search = Worksheets("sheet2").Cells(i, 1) Then
　　　　Cells(k, 3) = Worksheets("sheet2").Cells(i, 2)
End If
Next

としている事です。
　sheet1のA3～A10セル範囲内に入力されているデータのどれか1つと、sheet2のA2～A11の範囲内にに入力されているデータのどれか1つが一致した場合、その時点で

For k = 3 To 12

の下に記述されている

If search = Worksheets("sheet2").Cells(i, 1) Then

の部分の判定は、kの値が3～12のいずれの場合であってもTrueとなるのですから、sheet1のC列の中において3～12行の行範囲内の全てのセルに対して

Cells(k, 3) = Worksheets("sheet2").Cells(i, 2)

という処理が行われてしまい、sheet1のC3～C12のセル範囲内の全てのセルに同じ値が上書きされてしまいます。
　そのため、例えばもしもsheet1のA10セルに入力されている値と同じ値が、sheet2のA2～A11の範囲内にに入力されているデータのどれか1つと一致している場合には、sheet1のC3～C12のセル範囲内の全てのセルに「sheet1のA10セルに入力されている値」に対応するsheet2のC列の値が上書きされる事になります。

　ですから、質問者様がやりたかった方法で目的を果たすためには、次の様なVBAにする必要があります。

Sub kensak_修正()

Dim search As String
Dim i As Long
Dim j As Long

For j = 3 To 10
search = Cells(j, 1)
For i = 2 To 11
If search = Worksheets("sheet2").Cells(i, 1) Then
Cells(j, 3) = Worksheets("sheet2").Cells(i, 2)
End If
Next i
Next j
End Sub

　後それから、もしも"sheet2"というシート名のシートが存在していなかった場合や、sheet1のA列に値が入力されている範囲が10行を超えている場合、sheet2のA列に値が入力されている範囲が11行を超えている場合、逆にsheet1のA列かsheet2のA列のどちらかにデータが全く入力されていなかった場合、等においてエラーとならない様にするためには、次の様なVBAのマクロとした方が良いかも知れません。(こちらのVBAマクロの場合シート名や処理を行い始める開始行の行番号、「どの列に対してどの処理を行うのか」といった初期設定を、後から変更する必要が生じた際には、VBAの構文中においてどこに変更すべき記述が存在しているのかを一々探し回らずとも、冒頭部分にまとめて記述されている「Const 変数名 As データ形式 = 値」の形式で指定されている定数の値を変更する事によって行う事が出来ます)

Sub kensak_改()

Dim search As String
Dim c As Range
Dim SearchRange As Range
Dim SearchSheet As Worksheet
Const SearchSheetName As String = "sheet2"
Const KensakuchiColumn As Long = 1
Const SearchColumn As String = "A"
Const SearchColumns As Long = 2
Const OutputColumn As Long = 3
Const SearchFirstRow As Long = 2
Const DataFirstRow As Long = 3
Dim SearchLastRow As Long
Dim DataLastRow As Long

'検索先シートの有無を確認し、シートがある場合にはそのシートを変数に格納
If IsError(Evaluate("ROW('" & SearchSheetName & "'!A1)")) Then
MsgBox "検索範囲として設定されている" & vbCrLf & vbCrLf _
& SearchSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "該当シート無し"
Exit Sub
End If
Set SearchSheet = Worksheets(SearchSheetName)

'元データが入力されている一番下の行の行番号を取得するとともに、
'元データが無い場合にはマクロを終了
DataLastRow = Cells(Rows.Count, KensakuchiColumn).End(xlUp).Row
If DataLastRow < DataFirstRow Then
MsgBox "現在開いているシートには、処理を行うために必要な" _
& "元データが入力されていません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

'検索先データが入力されている一番下の行の行番号を取得するとともに、
'検索先データが無い場合にはマクロを終了
SearchLastRow = Cells(Rows.Count, SearchColumn).End(xlUp).Row
DataLastRow = Cells(Rows.Count, KensakuchiColumn).End(xlUp).Row
If DataLastRow < DataFirstRow Then
MsgBox "検索範囲として設定されている" & vbCrLf & vbCrLf _
& SearchSheetName & vbCrLf & vbCrLf & _
"というシート名のシートには、処理を行うために必要な" _
& "参照先のデータが入力されていません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
Set SearchRange = SearchSheet.Range(SearchColumn & SearchFirstRow _
& ":" & SearchColumn & SearchLastRow)

With Application
.ScreenUpdating = False ' モニター表示の更新を停止
.Calculation = xlManual ' 計算モードを手動に設定

' 開いているシートにおいて、元データが入力されているセル範囲に
'含まれているセルごとに繰り返し処理を行う
For Each c In Range(Cells(DataFirstRow, KensakuchiColumn), _
Cells(DataLastRow, KensakuchiColumn))
search = c.Value
If search <> "" Then
With .WorksheetFunction
If .CountIf(SearchRange, search) > 0 Then _
c.Offset(, OutputColumn - KensakuchiColumn) = .VLookup(search, _
SearchRange.Resize(, SearchColumns), SearchColumns, False)
End With
End If
Next c

.Calculation = xlAutomatic ' 計算モードを自動に設定
.ScreenUpdating = True ' モニター表示の更新を再開
End With

End Sub

回答No.2

real beatin（@realbeatin）

こんにちは。お邪魔します。

色んな方法がありますけれど、
> 検索行数が膨大で関数だと動きが重たくなるため
という動機＝目的でＶＢＡを組むのでしたら、
検索するのにセル範囲を二重にループするのでは非効率ではあります。
ご質問の趣旨はご提示のコードを動くようにしたい、というものだと承知しますが、
ここは目的に近付けるよう、敢えて別の方法を紹介してみようと思います。

どんな方法が目的に適うかは、'膨大'と呼ぶレコード数に依っても少し違いがありますが、
Excel VBA としては初級の段階で覚えておきたい range.Find メソッド を用いる例です。

以下のマクロについて、
技術的なことで、もし経験がないものがあれば、確認しておいた方がいいポイントとしては、
　　range.End プロパティを使った「最下（終）行の取得」
　　For Each ... Next ステートメントを使った「セル範囲の総当たりループ」
　　range.Find メソッドを使った「セル範囲の検索」
　　range.Offset プロパティを使った 相対参照
等です、
それぞれ、ＶＢＡのヘルプと、教則サイトまたは書籍、などで確認して
なるべく、意味が分かった上で使うように心掛けて貰うとベターです。

' ' /// Sub kensaku()
Sub ReW9071520()

Dim rTarget As Range　'　検索対象セル範囲　Sheet2.A列
Dim rFound As Range　'　検索結果セル　Sheet2.A列の単セル またはNothing
Dim c As Range　'　ループ用　検索キーセル　Sheet1.A列の単セル
Dim vBuf　'　転記する値 を 一時的に格納する変数

　　With Sheets("Sheet2")
　　　　Set rTarget = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)　'　A1を先頭にA列最下行までのセル範囲
　　End With

　　Application.ScreenUpdating = False　'　Excel 描画 一時停止（処理が遅くならないようにする為）

　　With Sheets("Sheet1")

　　　　For Each c In .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)　'　検索キー セル範囲　Sheet1.A列
　　　　　　If c.Value <> "" Then　'　検索キー が空でなければ以下の処理

' ' 検索対象セル範囲 で 検索キー(c.Value) が 見つかったセル を 検索結果セル(rFound) に 格納
　　　　　　　　Set rFound = rTarget.Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)

　　　　　　　　If rFound Is Nothing Then　'　検索結果 が 見つかっていなかった場合
　　　　　　　　　　vBuf = CVErr(xlErrNA)　'　＃N/A エラー値 を 変数(vBuf) に 格納
　　　　　　　　Else　　　　　　　　　　　　'　検索結果 が 見つかっていた場合
　　　　　　　　　　vBuf = rFound.Offset(, 1).Value　'　検索結果セル の １つ右のセルの値 を 変数(vBuf) に 格納
　　　　　　　　End If
　　　　　　　　c.Offset(, 2).Value = vBuf　'　変数(vBuf) の 値を 検索キーセル の ２つ右のセルに出力

　　　　　　End If
　　　　Next
　　End With

　　Application.ScreenUpdating = True　'　Excel 描画 再開

　　Set rFound = Nothing:　　Set rTarget = Nothing
End Sub
' ' ///

> どこが問題なのか調べられないため、
余裕がある時に、
　　「VBA デバッグの方法」
で検索してみて下さい。
これからのＶＢＡとの付き合い方にもよりますが、
デバッグを自分で出来るようになると、習熟（開発）の速度が飛躍的に向上します。

> なお、sheet1のA列には空白があっても空白行は飛ばして、次の行を検索・反映させる。
予め、'sheet1のA列'の空白でないセル範囲だけを捉えておいてから、
For Each ループ に掛ける方が効率的になりますが、
いきなり色々盛り込み過ぎるのも、却って良くないかな、と考えて、
今回は基本重視の内容でお応えしています。

もしも何かしら不足があった場合は、補足欄にでも書いてみて下さい。

回答No.1

dogs_cats

一例です。
Sub kensaku()

Dim search As String
Dim i As Long
Dim j As Long
Dim MaxR1, MaxR2 As Long
Dim ws As Worksheet

'sheet2を変数wsに格納
Set ws = Worksheets("sheet2")

'sheet2　Ａ列最終行取得
MaxR2 = ws.Cells(Rows.Count, 1).End(xlUp).Row

With Sheets("sheet1")

'sheet1　Ａ列最終行取得
MaxR1 = .Cells(Rows.Count, 1).End(xlUp).Row

'画面更新停止
Application.ScreenUpdating = False

For j = 3 To MaxR1

search = .Cells(j, 1)

For i = 2 To MaxR2
If search = ws.Cells(i, 1) Then
.Cells(j, 3) = ws.Cells(i, 2)
End If
Next i

Next j

End With

'画面更新再開
Application.ScreenUpdating = True

End Sub

for~nextが３重ループになっていますが、２重で出来ます。
sheet1を指定いなかったので　withステートメントで　sheets("sheet1")を指定しています。

with説明サイト
http://officetanaka.net/excel/vba/beginner/16.htm

sheet1、sheet2のA列の最終行を取得してforループを実行するようにしてあります。
（最終行まで実施しない場合は、数値に変更下さい）

実際は行数が多いようですので、処理中は画面更新を停止し、VBAの処理速度を早めるようにしています。実際の行数が質問のような１０行程度であればVLOOKUPで十分対応可能だと思います。数式を入力しないで結果だけ出力する方法が出来ます。

変数searchは別に無くても、 If .cells(j,1) = ws.Cells(i, 1) Then　で可能です。

sheet2が何度も出てくるので、オブジェクト変数wsに格納しています。
http://officetanaka.net/excel/vba/variable/04.htm