ExcelといえばVLOOKUP！っていうくらいこの関数をよく使います。というか関数はVLOOKUPとSUMくらいしかまともに使えません、、。勉強しなきゃ、、
今回は、VLOOKUP関数ではなくVBAで複数該当の値を取得したので、コピペできるようにメモしておきます。例として、ECサイトで特定の注文情報を取得したいとします。
VLOOKUPで注文番号に紐づく複数の商品を取得したかった
大好きなVLOOKUPですが、一部痒いところに手が届きません。例えば、抽出する該当箇所が複数ある場合、最初の1つしか取得できません。
具体的には、以下のように商品ごとに行がある注文データがあるとします。
今回の目的は、B列の注文番号を元に、D列の商品名を抽出します。
商品ごとに行があるので、１つの注文で数種類の商品を購入した場合、以下のように同じ注文番号で複数行の商品があります。※B列は注文番号、D列は商品名です。
例えば注文番号「8423023」は4つの商品を購入しているので、４列の注文データが存在することになります。
VLOOKUPで注文番号を元に商品名を抽出すると、最初の商品である50行目しかヒットしません。
注文番号に紐づくすべての商品を抽出するには、MATCH関数を使えば抽出できそうですが、今回はVBAで実装します！
注文番号に紐づく複数の商品を抽出するVBAを作成する
今回作成したデータ抽出のVBAは、ファイルに２つのタブシートを準備し、１つ目の「貼付用」にデータベース、２つ目の「抽出結果」に抽出データを出力するようにしました。
それぞれのタブに名前をつけていますが、今回のVBAでタブ名は必須です。
どのようにデータが取得できるか確認
「貼付用」タブのデータベースがこちらです。ここから必要な注文番号のデータを抽出します。
取得したデータを出力する「抽出結果」タブがこちらです。
抽出したい注文番号をA列（３行目以降）に入力して 「データを抽出する」ボタンをクリックすれば、該当の注文データが出力されます。
※「データを抽出する」ボタンにはこれから作成するVBAを登録します。
検索結果には、検索する注文番号が存在すればOK、なければ何も表示しないようにしました。
データ抽出VBA（コード全体）
そして、こちらがコード全体です！
Option Explicit
Dim pasteSheet As Worksheet
Dim resultSheet As Worksheet
Sub ckeckItem()
Dim rowNum As Long
Dim colNum As Long
Dim targetCode As Long
Dim resultRowNum As Long
Dim pastRowNum As Long
Dim displayNum As Long
' 表示する列を管理
displayNum = 3
Set pasteSheet = Worksheets("貼付用")
Set resultSheet = Worksheets("抽出結果")
' 貼付用シートを検索
For pastRowNum = 2 To pasteSheet.Cells(Rows.Count, 1).End(xlUp).Row
' 抽出用シートを検索
For resultRowNum = 3 To resultSheet.Cells(Rows.Count, 1).End(xlUp).Row
' 検索するコード
targetCode = resultSheet.Cells(resultRowNum, 1).Value
' コードが見つかった時の処理
If pasteSheet.Cells(pastRowNum, 2).Value = targetCode Then
resultSheet.Cells(resultRowNum, 2).Value = "OK"
resultSheet.Cells(displayNum, 3).Value = checkValue("注文番号", pastRowNum)
resultSheet.Cells(displayNum, 4).Value = checkValue("都道府県・市区町村", pastRowNum)
resultSheet.Cells(displayNum, 5).Value = checkValue("商品コード", pastRowNum)
resultSheet.Cells(displayNum, 6).Value = checkValue("商品名", pastRowNum)
resultSheet.Cells(displayNum, 7).Value = checkValue("数量", pastRowNum)
resultSheet.Cells(displayNum, 8).Value = checkValue("支払方法", pastRowNum)
' 表示する列を1つすすめる
displayNum = displayNum + 1
End If
Next resultRowNum
Next pastRowNum
End Sub
'項目から必要なデーターを抽出
Function checkValue(ByVal checkItem As String, ByVal rNum As Long) As String
Dim colNum As Long
Dim targetColNum As Long
Set pasteSheet = Worksheets("貼付用")
For colNum = 1 To pasteSheet.Cells(1, Columns.Count).End(xlToLeft).Column
If pasteSheet.Cells(1, colNum).Value = checkItem Then
checkValue = pasteSheet.Cells(rNum, colNum).Value
Exit For
Else
checkValue = "項目が見つかりませんでした"
End If
Next colNum
End Functionデータベースの構造や出力先のタブシートのレイアウトによっては、コードを一部変更する必要がありますが、例の通りに作成したファイルならコピペで動く、、、はずです。
抽出したい項目を変更する
取得するデータベースの項目名を変更したい時があると思います。
その場合、以下の色がついているところを変更すればOKです。
resultSheet.Cells(displayNum, 3).Value = checkValue("注文番号", pastRowNum)出力する箇所を変更すれば色々と応用ができそうです。
まとめ
Excelは触っていて楽しいですが、使わないとすぐに忘れてしまいます。
今回の実装は、もっと簡単な方法があると思いますが、せっかく動くようになったので残しておきます！
