VBAでの部分一致検索の仕方

Question

実現したいこと

• 検索システムでand・or検索を実装した際に、完全一致ではなく部分一致でも該当のデータが抽出されるようにしたい。

• 検索対象のファイルがアクティブでない状態でも検索がかけられるようにしたい。

前提

管理のためにマスターデータを作成し、検索システムを使用することで該当のデータをいち早く見つけ効率よく作業ができるようにしたいと思い、パソコンスキルの教科書さんを参考にマクロを作成しています。

マスターデータは項目ごとにシートが3つに分かれており、元号でファイルが分けられています。
そのため、閉じられているExcelファイルに対して複数条件検索をかけ、なおかつ該当データを抽出して一覧を作成できるようにしたいです。

発生している問題・エラーメッセージ

上記ページで紹介されているコードは下記に記載させていただきますが、私の力不足で上手く編集できず次の2点でつまずいております。

・マスターデータが同じファイルの別シートにある前提
・検索条件が完全一致となっていて部分一致ができない

該当のソースコード

'プログラム0｜変数宣言の指定
Option Explicit

'プログラム1｜プログラム開始
Sub ExtractData()

    'プログラム2｜シート設定
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("ExtractedData")
    
    'プログラム3｜各シートの最終行を取得
    Dim cmax1 As Long, cmax2 As Long
    cmax1 = ws1.Range("A65536").End(xlUp).Row
    cmax2 = ws2.Range("A65536").End(xlUp).Row
    
    'プログラム4｜データをリセット
    ws2.Range("B6:B7").ClearContents
    If Not cmax2 = 9 Then: ws2.Range("A10:E" & cmax2).ClearContents
    
    'プログラム5｜開始日と終了日を取得
    Dim startdate As Date, enddate As Date
    startdate = ws2.Range("B2").Value
    enddate = ws2.Range("B3").Value
    
    'プログラム6｜取引先を取得
    Dim torihiki As String
    torihiki = ws2.Range("B4").Value
    
    'プログラム7｜開始日、終了日、取引先が空欄か判定
    Dim flag(2) As Boolean ' BooleanのDefault値はFalse
    If startdate = 0 Then: flag(0) = True
    If enddate = 0 Then: flag(1) = True
    If torihiki = "" Then: flag(2) = True
    
    'プログラム8｜変数の初期化
    Dim n As Long: n = 10
    Dim goukei As Long: goukei = 0
    Dim kensu As Long: kensu = 0
    
    'プログラム9｜条件に合致した行を抽出
    Dim i As Long
    For i = 2 To cmax1
        If flag(0) = False Then
            If ws1.Range("C" & i).Value < startdate Then: GoTo Continue
        End If
        
        If flag(1) = False Then
            If ws1.Range("C" & i).Value >= enddate Then: GoTo Continue
        End If
        
        If flag(2) = False Then
            If ws1.Range("E" & i) <> torihiki Then: GoTo Continue
        End If
    
        'プログラム10｜条件に合致した行のデータのみを対象して分析
        ws2.Range("A" & n & ":E" & n).Value = ws1.Range("A" & i & ":E" & i).Value
        goukei = goukei + ws1.Range("D" & i).Value
        kensu = kensu + 1
        n = n + 1
        
'プログラム11｜プログラム9で条件に合致しなかった場合、ここへジャンプ
Continue:
    Next
        
    'プログラム12｜合計値と件数を出力
    ws2.Range("B6").Value = goukei
    ws2.Range("B7").Value = kensu
    
'プログラム13｜プログラム終了
End Sub

試したこと

 'プログラム9｜条件に合致した行を抽出
    Dim i As Long
    For i = 2 To cmax1
        If flag(0) = False Then
            If ws1.Range("C" & i).Value < startdate Then: GoTo Continue
        End If
        
        If flag(1) = False Then
            If ws1.Range("C" & i).Value >= enddate Then: GoTo Continue
        End If
        
        If flag(2) = False Then
            If ws1.Range("E" & i) <> torihiki Then: GoTo Continue
        End If

上記コード内のプログラム9のtorihiki部分を>torihiki にしてみたり、>1にしてみたりしました。
色々調べてみたのですが、関連した項目を見つけられず、数学的な考えで＞が含む、
＞1が何かしらの値・文字が入っていればという意味合いなのかなと思い試してみたのですが、
余計に訳が分からなくなり、今に至ります。

分かりにくい上に丸投げになっているように捉えられかねない内容となってしまっているかもしれませんが、皆様のお力をお借りしたく思います。
何卒宜しくお願い致します。

---

追記1
tatsu99様
以下ご確認のほどお願い致します。

＜マスターデータ＞

'プログラム0｜変数宣言の指定
Option Explicit

'プログラム開始
Sub ExtractData()

    'シート設定
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("概要一覧")
    Set ws2 = ThisWorkbook.Worksheets("検索と抽出")
    
    '各シートの最終行を取得
    Dim cmax1 As Long, cmax2 As Long
    cmax1 = ws1.Range("A1048576").End(xlUp).Row
    cmax2 = ws2.Range("A1048576").End(xlUp).Row
    
    '購入先を取得
    Dim torihiki As String
    torihiki = ws2.Range("C2").Value
    
    '購入品の種類1を取得
    Dim bihin1 As String
    bihin1 = ws2.Range("C3").Value
    
    '購入品の種類2を取得
    Dim  bihin2 As String
     bihin2 = ws2.Range("C4").Value
    
    '開始日と終了日を取得
    Dim startdate As Date, enddate As Date
    startdate = ws2.Range("C5").Value
    enddate = ws2.Range("C6").Value
    
    
    '検索項目が空欄か判定
    Dim flag(4) As Boolean ' BooleanのDefault値はFalse
    If torihiki = "" Then flag(0) = True
    If rokasenn = "" Then flag(1) = True
    If kasyo = "" Then flag(2) = True
    If startdate = 0 Then flag(3) = True
    If enddate = 0 Then flag(4) = True
    
    '変数の初期化
    Dim n As Long: n = 12
    
    '条件に合致した行を抽出
    Dim i As Long
    For i = 3 To cmax1
        If flag(0) = False Then
            If InStr(1, ws1.Range("C" & i).Value, torihiki, vbTextCompare) = 0 Then: GoTo Continue
        End If
        
        If flag(1) = False Then
            If InStr(1, ws1.Range("E" & i).Value,  bihin1, vbTextCompare) = 0 Then: GoTo Continue
        End If
        
        If flag(2) = False Then
            If InStr(1, ws1.Range("F" & i).Value,  bihin2, vbTextCompare) = 0 Then: GoTo Continue
        End If
        
        If flag(3) = False Then
            If ws1.Range("J" & i).Value < startdate Then: GoTo Continue
        End If
        
        If flag(4) = False Then
            If ws1.Range("J" & i).Value >= enddate Then: GoTo Continue
        End If
    
        '条件に合致した行のデータのみを対象して分析
        ws2.Range("A" & n & ":M" & n).Value = ws1.Range("A" & i & ":M" & i).Value
        n = n + 1
        
'プログラム9で条件に合致しなかった場合、ここへジャンプ
Continue:
    Next
        
    '合計値と件数を出力
    Range("C8").Value = Application.WorksheetFunction.CountA(Range("A12:A1048576"))
    
'プログラム終了
End Sub

Sub delete()

    'シート設定
    Dim ws2 As Worksheet
    Set ws2 = ThisWorkbook.Worksheets("検索と抽出")
    Dim cmax2 As Long

    ws2.Range("C2,C3,C4,C5,C6,C8").ClearContents
    If Not cmax2 = 11 Then: ws2.Range("A12:M10000" & cmax2).ClearContents

End Sub

また、再度のご質問となり申し訳ございませんが、下記コードで抽出・転記していると思うのですが、マスターデータのテーマを使用してすべてを貼り付けたいので、「xlPasteAllUsingSourceTheme」に書き換えたいのですが、うまくいきません…。
こちらも併せてご教示いただけますと嬉しく思います。
何卒宜しくお願い申し上げます。

'条件に合致した行のデータのみを対象して分析
        ws2.Range("A" & n & ":M" & n).Value = ws1.Range("A" & i & ":M" & i).Value
        n = n + 1

---

追記2
tatsu99様
再度ご確認のほど、宜しくお願い申し上げます。

＜検索用の画面の検索項目指定箇所＞
着色部分が検索項目として使用するものになります。

＜検索結果の表示部分＞
同様の項目をタイトルとして、検索ワードに該当した1行が転記されるようにしています。

上記2枚の画像でよろしいでしょうか…？

Comments

[tatsu99]

>マスターデータは項目ごとにシートが3つに分かれており、元号でファイルが分けられています。
「項目ごとにシートが３つに分かれており」とは、どういうことでしょうか、
そのまま、解釈するとIDが3つのシートに分かれており、取引先も３つのシートに分かれており、
ということなので、「パソコンスキルの教科書」のSheet1が３つあるということでしょうか。
（３つのシートが検索対象となる）

元号でファイルが分けられており、ということですが、検索対象のブックが３つあるということでしょうか。
そうすると３ブックが検索対象で１ブック内に３シートあるので、計９シートが検索対象となるということでしょうか。
また、閉じられているExcelファイルということなので、３ブックは閉じた状態であることが前提となり、
マクロの開始後に、３ブックをオープンし、検索完了後、３ブックをクローズしたいということでしょうか。

[shibakoppe]

tatsu99様
ご質問並びにご回答ありがとうございます。

＞「項目ごとにシートが３つに分かれており」とは、どういうことでしょうか
管理部署が異なる為、部署ごとにシートがある＝3つのシートに分かれているということになります。
1つのExcelファイルに3つのシートが存在しており、そのシート内には取引先等が一覧で入力されている形になります。

＞元号でファイルが分けられており、ということですが、検索対象のブックが３つあるということでしょうか。
そうすると３ブックが検索対象で１ブック内に３シートあるので、計９シートが検索対象となるということでしょうか。
おっしゃるとおりです。
＞また、閉じられているExcelファイルということなので、３ブックは閉じた状態であることが前提となり、
マクロの開始後に、３ブックをオープンし、検索完了後、３ブックをクローズしたいということでしょうか。
そのような処理ができれば一番良いと考えてはいるのですが、処理に時間がかかる場合は、別のマスターデータを用意し、1ブック１シートになるように変更しようかと思っています。

[tatsu99]

>1つのExcelファイルに3つのシートが存在しており、そのシート内には取引先等が一覧で入力されている形になります。
この３つのファイルのレイアウトは、全て同じでしょうか。
又、3のブックで３シートある為、９つのシートは全て、同じレイアウトと考えて良いですか。
３ブック内の３シートのシート名は、全て同じでしょうか。
例　
昭和.xlsx に "シートA","シートB","シートC" があり、
平成.xlsx に "シートA","シートB","シートC" があり、
例和.xlsx に "シートA","シートB","シートC" がある。

又、これらのシートは、パソコンスキルの教科書で提示されたSheet1のレイアウトと同じと考えて良いのでしょうか。

[shibakoppe]

＞この３つのファイルのレイアウトは、全て同じでしょうか。
　又、3のブックで３シートある為、９つのシートは全て、同じレイアウトと考えて良いですか。
　３ブック内の３シートのシート名は、全て同じでしょうか。
おっしゃるとおりです。

＞又、これらのシートは、パソコンスキルの教科書で提示されたSheet1のレイアウトと同じと考えて良いのでしょうか。
レイアウトは少々異なります。
タイトル行が2行になっています。

[tatsu99]

提示された画像を確認しました。
以下、確認です。
１．３つのブックの各３つのシートを検索対象にする。（シート名は部署1,部署2,部署3）
２．ブック名を提示してください。
３．３つのブックは同じフォルダに格納されている前提で良いですか。
４．データの保守期間の始と終ですが、このセルが空白の場合がありますか。それとも必ず日付が設定されていますか。

[tatsu99]

or条件で検索する場合の仕様の確認です。
１．条件が空白（C列が空白）の場合は、その条件は無視する。
従って、C２～C6が全て空白の場合、１件も抽出対象とならない。
（and条件で検索の場合は、C２～C6が全て空白の場合、全データが抽出対象となる）
２．指定された条件の何れが成立した場合、抽出対象となる。
例１　購入先と購入品の種類１が指定された場合、購入先がマッチ、種類１がマッチの何れかが成立すれば、抽出対象となる。
例２　５つの項目が全て指定された場合、５つの条件のうち、どれかが成立すれば、抽出対象となる。

上記の条件での検索となりますが、それで良いでしょうか。

[shibakoppe]

１．３つのブックの各３つのシートを検索対象にする。（シート名は部署1,部署2,部署3）
　　⇒おっしゃる通りです。
２．ブック名を提示してください。
　　⇒01_昭和分管理簿.xlsx
　　　02_平成分管理簿.xlsx
　　　03_令和分管理簿.xlsx
　　　としています。
３．３つのブックは同じフォルダに格納されている前提で良いですか。
　　⇒問題ありません。
４．データの保守期間の始と終ですが、このセルが空白の場合がありますか。それとも必ず日付が設定されていますか。
　　⇒空白の時もあります。

[shibakoppe]

＞or条件で検索する場合の仕様の確認です。
　ご提示いただいた条件で問題ありません。
　ご丁寧にありがとうございます。

[tatsu99]

日付の検索のについての確認です。
以下であってますか。（andでもorでも同様）
保守期間始が指定された場合、指定日付以降のものが抽出対象となる。（指定日付含む）
保守期間終が指定された場合、指定日付以前のものが抽出対象となる。（指定日付含む）
保守期間始が指定された場合、データの保守期間始が空白なら、抽出対象にならない。
保守期間終が指定された場合、データの保守期間終が空白なら、抽出対象にならない。

[shibakoppe]

＞日付の検索のについての確認です。
　ご提示いただいた条件で問題ありません。

Answer 1

完全一致を部分一致に変える場合は、
If ws1.Range("E" & i) <> torihiki Then: GoTo Continue
を
If InStr(1, ws1.Range("E" & i).Value, torihiki, vbTextCompare) = 0 Then: GoTo Continue
にすれば良いです。

Comments

[shibakoppe]

ご回答いただき、誠にありがとうございます。
ご教示いただいた方法で、部分一致で検索できるようになりました。
また、差し出がましいお願いとなってしますのですが、現時点のコードですとand検索のみに対応している形になってしまっているので、or検索にも対応できるようにする際の記述もご教示いただくことは可能でしょうか…？
現時点で私が考えているのは
・and検索とor検索をボタンで切り替える
　⇒ご教示いただいたコードと元々あるコードをそれぞれ動かす
といった形にしようと思っているのですが、非効率な気がしていて…
なにか良い手段があればご教示いただければ幸いです…。

[tatsu99]

＞・and検索とor検索をボタンで切り替える
とは、現在の検索ボタンをand検索用に使い、新たにor検索用のボタンをを追加して、
どちらかのボタンをクリックしてもらうということでしょうか。

[shibakoppe]

＞どちらかのボタンをクリックしてもらうということでしょうか。
　主に使用する方からするとそのようにした方がわかりやすいのではと考えています。

[tatsu99]

or条件にした場合は、どのような条件で検索するのでしょうか。

①納品日が集計開始日以降
②納品日が集計終了日以前
③取引先が指定取引先に部分一致
上記の①②③の何れかが成立の場合、表示でしょうか。

そうした場合、そのような条件を指定することに、あまり意味がないような気がします。
又、①②③の入力で空白を許す場合は、全データが対象となるので、
①②③のどれかが空白なら、全て集計対象になります。
or条件にするご利益があまり感じられませんが、本当に必要なのでしょうか。

[shibakoppe]

上記記載のコードはサイトに記載されていたものをそのまま掲載させていただいているのですが、
実際は1.購入先、2.購入品の種類（電子機器や文房具等）、3.使用状況（修理中や使用中等）、4.購入品の保証の開始日、5.終了日といった項目で管理しているデータから抽出したいのです。
そのような理由からor検索を必要としています。
提示条件が異なっており申し訳ありません。

[tatsu99]

>上記記載のコードはサイトに記載されていたものをそのまま掲載させていただいているのですが、
実際は1.購入先、2.購入品の種類（電子機器や文房具等）、3.使用状況（修理中や使用中等）、4.購入品の保証の開始日、5.終了日といった項目で管理しているデータから抽出したいのです。

そうなると、現行のサイトに記載されていたソースにor条件を追加しても、実際の環境に変換するための労力がまた発生するので、直接、実際のデータを検索する前提でマクロを作成したほうが良いかと思います。
実際のシートのレイアウト及び、検索条件を指定及び検索結果表示のレイアウトを画像で提示していただいた方が良いかと思います。
現行のサイトに記載されていたソースにor条件を追加するだけで良いなら、その旨返信ください。

[shibakoppe]

承知いたしました。
質問に追記させていただきますので、ご確認いただきたく思います。
お手数をおかけしますが、宜しくお願い致します。

[tatsu99]

検索対象シートのレイアウトの提示ありがとうございました。
検索用の画面の検索項目指定箇所及び検索結果の表示部分の画像も提示していただけませんでしょうか。

[shibakoppe]

こちらこそありがとうございます。
追記に提示させていただきますので、ご確認のほどよろしくお願いします。

Answer 2

AND条件の場合は、AND検索を呼び出してください。
OR条件の場合は、OR検索を呼び出してください。
簡単な動作確認は行っています。
詳細のチェックは行っていませんので、チェック漏れがあるかもしれません。

Option Explicit

'共有変数
Dim ws1 As Worksheet, ws2 As Worksheet
    Dim cmax1 As Long, cmax2 As Long
    Dim torihiki As String
    Dim bihin1 As String
    Dim bihin2 As String
    Dim startdate As Date, enddate As Date
    Dim flag(4) As Boolean
    Dim row2 As Long   '検索結果出力行

Public Sub AND検索()
    Call 検索処理("AND")
End Sub

Public Sub OR検索()
    Call 検索処理("OR")
End Sub

Private Sub 検索処理(ByVal joken As String)
    Const Folder As String = "D:\goo\data9"    'ブック格納フォルダ
    Dim wb As Workbook
    Dim bname As Variant: bname = Array("01_昭和分管理簿.xlsx", "02_平成分管理簿.xlsx", "03_令和分管理簿.xlsx")
    Dim sname As Variant: sname = Array("部署1", "部署2", "部署3")
    Dim i As Long
    Dim j As Long
    Application.ScreenUpdating = False
    Set ws2 = ThisWorkbook.Worksheets("検索と抽出")
    '各シートの最終行を取得
    cmax2 = ws2.Range("A1048576").End(xlUp).row
    '出力領域クリア
    If cmax2 >= 12 Then
        ws2.Range("A12:M" & cmax2).ClearContents
    End If
    '購入先を取得
    torihiki = ws2.Range("C2").Value

    '購入品の種類1を取得
    bihin1 = ws2.Range("C3").Value

    '購入品の種類2を取得
    bihin2 = ws2.Range("C4").Value

    '開始日と終了日を取得
    startdate = ws2.Range("C5").Value
    enddate = ws2.Range("C6").Value

    For i = 0 To UBound(flag)
        flag(i) = False
    Next
    '検索項目が空欄か判定
    If torihiki = "" Then flag(0) = True
    If bihin1 = "" Then flag(1) = True
    If bihin2 = "" Then flag(2) = True
    If startdate = 0 Then flag(3) = True
    If enddate = 0 Then flag(4) = True
    '変数初期化
    row2 = 12
    '３ブックを処理
    For i = 0 To UBound(bname)
        Dim path As String
        path = Folder & "\" & bname(i)
        Set wb = Workbooks.Open(path)
        '３シートを処理
        For j = 0 To UBound(sname)
            Set ws1 = wb.Worksheets(sname(j))
            '１シートを検索
            Call FindProc(joken)
        Next
        wb.Close
    Next
    Application.ScreenUpdating = True
End Sub
'1シートの検索
Private Sub FindProc(ByVal joken As String)
    cmax1 = ws1.Range("A1048576").End(xlUp).row
    Dim ret As Boolean
    Dim row1 As Long
    For row1 = 3 To cmax1
        If joken = "AND" Then
            ret = FindAND(row1)
        Else
            ret = FindOR(row1)
        End If
        If ret = True Then
            '条件に合致した行のデータのみを対象して分析
            ws1.Range("A" & row1 & ":M" & row1).Copy
            ws2.Range("A" & row2 & ":M" & row2).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
            row2 = row2 + 1
        End If
    Next
    '合計値と件数を出力
    ws2.Range("C8").Value = Application.WorksheetFunction.CountA(ws2.Range("A12:A1048576"))
End Sub
'AND 検索(True:マッチ,False:アンマッチ)
Private Function FindAND(ByVal row1 As Long) As Boolean
    FindAND = False
        If flag(0) = False Then
            If InStr(1, ws1.Range("C" & row1).Value, torihiki, vbTextCompare) = 0 Then Exit Function
        End If
        
        If flag(1) = False Then
            If InStr(1, ws1.Range("E" & row1).Value, bihin1, vbTextCompare) = 0 Then Exit Function
        End If
        
        If flag(2) = False Then
            If InStr(1, ws1.Range("F" & row1).Value, bihin2, vbTextCompare) = 0 Then Exit Function
        End If
        
        If flag(3) = False Then
            If ws1.Range("K" & row1).Value = "" Then Exit Function
            If ws1.Range("K" & row1).Value < startdate Then Exit Function
        End If
        
        If flag(4) = False Then
            If ws1.Range("L" & row1).Value = "" Then Exit Function
            If ws1.Range("L" & row1).Value > enddate Then Exit Function
        End If
        FindAND = True
End Function
'OR 検索(True:マッチ,False:アンマッチ)
Private Function FindOR(ByVal row1 As Long) As Boolean
    FindOR = True
    If flag(0) = False Then
        If InStr(1, ws1.Range("C" & row1).Value, torihiki, vbTextCompare) > 0 Then Exit Function
    End If

    If flag(1) = False Then
        If InStr(1, ws1.Range("E" & row1).Value, bihin1, vbTextCompare) > 0 Then Exit Function
    End If

    If flag(2) = False Then
        If InStr(1, ws1.Range("F" & row1).Value, bihin2, vbTextCompare) > 0 Then Exit Function
    End If

    If flag(3) = False Then
        If ws1.Range("K" & row1).Value <> "" Then
            If ws1.Range("K" & row1).Value >= startdate Then Exit Function
        End If
    End If

    If flag(4) = False Then
        If ws1.Range("L" & row1).Value <> "" Then
            If ws1.Range("L" & row1).Value <= enddate Then Exit Function
        End If
    End If
    FindOR = False
End Function

Comments

[tatsu99]

Const Folder As String = "D:\goo\data9"
は、ブック格納フォルダです。
私の試験環境なので、あなたの環境にあわせて、適切に設定してください。

[shibakoppe]

本当にありがとうございます…！
無事動きました…！！
ご丁寧にお付き合いいただき、本当に助かりました。
作業手順が多く長いコードを書かせてしまって申し訳ございませんでした。

Answer 3

＞下記コードで抽出・転記していると思うのですが、マスターデータのテーマを使用してすべてを貼り付けたいので、「xlPasteAllUsingSourceTheme」に書き換えたいのですが、うまくいきません…。

    ws2.Range("A" & n & ":M" & n).Value = ws1.Range("A" & i & ":M" & i).Value

を
ws1.Range("A" & i & ":M" & i).Copy
ws2.Range("A" & n & ":M" & n).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
に変えてください。

Comments

[shibakoppe]

返信が遅くなり申し訳ございません。
追加の質問にもご対応いただきありがとうございます。
無事動作いたしました。
本当にありがとうございます。