いずれかの条件を含むデータを全て抽出したい

質問

シート1(ここに貼り付ける)に元データを貼り付けたら、シート2、シート3に必要なデータを自動で抽出出来るような関数を組みたいです。
シート1のD列の商品名の中に「標準」か「キャリブ」いずれかの文字を含むものはシート2に。「染色」か「マルチ」いずれかの文字を含むものでB列が「血液検査」のものはシート3に。というように条件を複数指定して、該当するものは丸々抽出したいです。どなたか分かる方教えてください。よろしくお願い致します！

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.4

HohoPapa

VBAを持ち込んでいいのであれば、
（SQL文も使うので若干ハードルが上がりますが）
後記コードはいかがでしょうか？

"ここに貼り付ける"というシートから
"Sheet2"、"Sheet3"というシートに出力しています。

抽出条件は、SQL文を見てもらえばおおよそ推測できると思います。
また、列名の末尾に「.(ドット)」が使われているので
出力先列名で文字化けが起きるかもしれません。
その場合は指摘してください。
コードを修正します。

よかったら挑戦してみてください。

Option Explicit

Sub sample()
　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim i As Long

　'Sheet2に抽出==============

　'SQL全文を組み立て
　SQL = ""
　SQL = SQL & "SELECT *" & vbCrLf
　SQL = SQL & "FROM [" & "ここに貼り付ける" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "WHERE (([商品名] LIKE '%標準%') or " & vbCrLf
　SQL = SQL & " ([商品名] LIKE '%キャリブ%')) " & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　'結果セットを出力
　With ThisWorkbook.Sheets("Sheet2")　　'出力先シートの指定
　　.Cells.ClearContents '出力先クリアー
　　For i = 0 To (rs.Fields.Count - 1) '列名を出力
　　　.Cells(1, i + 1).Value = rs.Fields(i).Name
　　Next
　　.Cells(2, 1).CopyFromRecordset rs
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

　'Sheet3に抽出==============

　'SQL全文を組み立て
　SQL = ""
　SQL = SQL & "SELECT *" & vbCrLf
　SQL = SQL & "FROM [" & "ここに貼り付ける" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "WHERE (([商品名] LIKE '%染色%') or " & vbCrLf
　SQL = SQL & " ([商品名] LIKE '%マルチ%')) and " & vbCrLf
　SQL = SQL & " ([在庫部署] = '血液検査') " & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　'結果セットを出力
　With ThisWorkbook.Sheets("Sheet3")　'出力先シートの指定
　　.Cells.ClearContents '出力先クリアー
　　For i = 0 To (rs.Fields.Count - 1) '列名を出力
　　　.Cells(1, i + 1).Value = rs.Fields(i).Name
　　Next
　　.Cells(2, 1).CopyFromRecordset rs
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

補足

回答ありがとうございます！
最初はマクロで作成していたのですが、途中うまくいかず関数でも作成していました。
マクロ使用可ですので挑戦してみます。ありがとうございます！^ ^