【VBA】複数条件のVLOOKUP

質問

【VBA】複数条件のVLOOKUP

いつもこちらの識者の方々にはお世話になっています。
VBAの質問です。

sheet1に下記のような表があります。
品目　　　入荷日　　　出荷日
バナナ　　7月1日　　　7月5日
りんご　　7月5日　　　8月24日
みかん　　8月5日　　　8月30日

sheet2には下記の表があります。
品目　　　入荷日　　　出荷日　　　箱
バナナ　　7月1日　　　7月5日　　　黄
りんご　　7月5日　　　8月24日　　赤
みかん　　8月5日　　　8月30日　　オレンジ
バナナ　　6月28日　　8月30日　　　緑
りんご　　6月20日　　7月5日　　　青
みかん　　6月18日　　8月24日　　朱

この表のsheet1の、品目・入荷日・出荷日の全ての項目が一致しているものをsheet2から探し、sheet1ののD2セル以降に箱の色をあてはめていきたいのですが、&で文字列をくっつけた検索用の行を作ることができないため難儀しています。
作業用の列を作らずにやる場合、どういった構文が適していますでしょうか。

回答No.3

tom04 · ベストアンサー

こんばんは！

＞&で文字列をくっつけた検索用の行を作ることができないため・・・
とありますが、作業用の列を設けては具合が悪いことがあるのでしょうか？

質問ではVBAでの方法となっていますが、VBAでも作業用の列を設けた方が簡単だと思うのですが、
今回は質問通りに作業用の列を設けずにやってみました。
標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1() 'この行から
Dim i As Long, k As Long, endRow As Long, wS1 As Worksheet, ws2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
endRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
If endRow > 1 Then
Range(wS1.Cells(2, "D"), wS1.Cells(endRow, "D")).ClearContents
End If
For i = 2 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To ws2.Cells(Rows.Count, "A").End(xlUp).Row
With wS1.Cells(i, "A")
If .Value = ws2.Cells(k, "A") And .Offset(, 1) = ws2.Cells(k, "B") And .Offset(, 2) = ws2.Cells(k, "C") Then
.Offset(, 3) = ws2.Cells(k, "D")
End If
End With
Next k
Next i
Application.ScreenUpdating = True
End Sub 'この行まで

※　二重ループになりますので、そこそこ時間を要するかもしれません。
※　VBAですので、列挿入　→　作業列として使用　→　挿入列を削除！
といった感じでやればもう少しはやくなると思います。m(_ _)m

お礼

ありがとうございます。
一つ一つ紐解きながら理解していこうと思います。

回答No.5

mitarashi

最近Workbookに対するADOの適用に凝っているのでご参考までに。xl2007以降対応です。
'日付は見た目7月5日ですが、2013/7/5といった日付シリアルで入っている事を前提としています。
'Microsoft ActiveX Data Objects Libraryに参照設定が必要　詳細は下記参照の事
'http://okwave.jp/qa/q8243178.html
Sub test()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim SQL As String
Dim i As Long
Dim targetRange As Range, targetRow As Range
Const srcSQL As String = "SELECT [箱] FROM [Sheet2$] WHERE [品目]='criteria1' AND [入荷日]=#criteria2# AND [出荷日]=#criteria3#;"

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties").Value = "Excel 12.0 Macro;HDR=YES"
.Open ThisWorkbook.FullName
End With
With Sheets("Sheet1")
Set targetRange = .Range("A1").CurrentRegion
Set targetRange = Intersect(targetRange, targetRange.Offset(1, 0))
End With
For Each targetRow In targetRange.Rows
SQL = srcSQL
For i = 1 To 3
SQL = Replace(SQL, "criteria" & CStr(i), targetRow.Cells(i).Value)
Next i
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
If Not rs.BOF Then
targetRow.Cells(3).Offset(0, 1).Value = rs.Fields(0).Value
End If
rs.Close
Next targetRow
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
'2シート間のクエリで一気に目的のデータを生成して別シートに貼り付ける方法もありそうですが、順番が変わったりしそうなので、ここではSheet1の行毎にループを回す方法をとっています。

お礼

凄すぎます・・・
凄すぎて今の僕にはほとんどわかりませんでした。
でも一つ一つ勉強していってこのレベルまで到達できるよう頑張ります！

回答No.4

MackyNo1

関数で対応するなら、D2セルに連結文字を検索値とする以下のような数式が計算負荷が少ないと思います。

=INDEX(Sheet2!$D$2:$D$1000,MATCH(A2&B2&C2,INDEX(Sheet2!$A$2:$A$1000&Sheet2!$B$2:$B$1000&Sheet2!$C$2:$C$1000,),0))&""

お礼

関数でもできるんですね！
絶対無理だと思い込んでました。
素晴らしいです。

回答No.2

MSZ006

sheet1のD2セルに

=INDEX(Sheet2!D:D,SUMPRODUCT((Sheet2!A:A=A2)*(Sheet2!B:B=B2)*(Sheet2!C:C=C2)*ROW(Sheet2!A:A)))

と入力、下にドラッグでコピーしてみてください。

お礼

関数でもできるんですね！
絶対無理だと思い込んでました。
素晴らしいです。

回答No.1

tsubuyuki

根本から。

> &で文字列をくっつけた検索用の行を作ることができない

この理由をできれば詳しく補足ください。

お礼

すみませんでした。説明不足で。
256列全て埋まっているんですが、よく考えたら別シートに作業列を作ったりできますね。