セルに入力された条件に基づいてファイルからデータを抽出する

Question

前提・実現したいこと

同じフォルダ内の複数のファイルから抽出先シートに入力したセルの条件に応じてデータを抽出する。

◆条件が入力されているセル番地
a）商品名：B4
b）期間:B6（以降）B7（以前）
c）抽出するシート名：F4
d）抽出すべき項目：F6～F10
e）抽出しない項目：F12～F16

◆複数のファイル
A列～J列までデータがあります。
a）はB列
b）はC列
d）とe）はD列を参照してます。

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

前任者が作成したコードです。
マクロの知識が低いため1.2.を追加するためにアドバイスをお願いいたします。

1.抽出先をF4に入力されたシートにすることができない。
2.抽出すべき項目と抽出しない項目をF6～F10、F12～F16に入力された条件に基づいて抽出できない。

該当のソースコード

Sub OneInstance01()
    Dim dstSheet      As Worksheet
    Dim Ns            As Worksheet
    Dim mPath         As String
    Dim buf           As String
    Dim i             As Long
    Dim y             As Long
    Dim srcBook       As Workbook
    Dim Base
    Dim Namae         As String
    Dim Sd            As Date
    Dim Ed            As Date
    Dim WF            As Object
    Set WF = WorksheetFunction
    Set dstSheet = ThisWorkbook.Worksheets("抽出条件")
    If Not Evaluate("=ISREF(抽出先シート!A1)") Then Sheets.Add.Name = "抽出先シート"
    Set Ns = Worksheets("抽出先シート")
    Ns.UsedRange.Clear
    mPath = ThisWorkbook.Path & "\"
    buf = Dir(mPath & "*.xls*")
    y = 2
    With dstSheet
        Namae = .Range("B4").Value
        Sd = .Range("B6").Value
        Ed = .Range("B7").Value
    End With
    Do While buf <> ""
        If buf <> ThisWorkbook.Name Then
            Set srcBook = Workbooks.Open(mPath + buf)
            Base = Intersect(srcBook.Worksheets("Sheet1").UsedRange, srcBook.Worksheets("Sheet1").Range("A:J"))
            For i = 1 To UBound(Base, 1)
                If Base(i, 1) = Namae And Base(i, 3) >= Sd And Base(i, 3) <= Ed Then
                    Ns.Cells(y, 2).Resize(, UBound(WF.Index(Base, i, 0))) = WF.Index(Base, i, 0)
                    y = y + 1
                End If
                DoEvents
            Next
            srcBook.Close False
        End If
        buf = Dir()
        'Erase Base
    Loop
    Set dstSheet = Nothing
    Set srcBook = Nothing
    Set Ns = Nothing
    Set WF = Nothing
End Sub

追記

・必ず入力するセル
a）商品名：B4
b）期間:B6（以降）B7（以前）
c）抽出するシート名：F4

※　抽出すべき項目と抽出しない項目は入力しない場合があります。　
入力しない場合は商品名と期間の条件で全て抽出します。

※　抽出すべき項目と抽出しない項目はどちらか一方のみ入力します。
同時に入力することはありません。
100項目のうち、抽出すべき項目が99件、抽出しない項目が1件の場合に抽出しない項目1件を
入力するようにしております。

Comments

[y_waiwai]

このままではコードが読みづらいので、質問を編集し、<code>ボタンを押し、出てくる’’’の枠の中にコードを貼り付けてください

[ichigo15]

コードが読みづらく申し訳ございません。
編集してみましたのでご確認ください。

[KazuSaka]

質問です。
商品名と期間は必ず入力されますよね？
抽出項目と抽出対象外の項目が未入力の場合、商品名と期間の条件ですべて抽出する感じですか？
抽出項目と抽出対象外項目が同時に入力されることはないですよね？
（両方入力だと、抽出対象項目のみを設定するのと同じになりますよね？）

以上

[ichigo15]

ご指摘ありがとうございます。
説明が不足しており申し訳ございません。

追記しましたのでご確認ください。

[KazuSaka]

それでしたら、私が回答した内容で、問題ないかと思います。ご確認ください。

Answer 1

※初期回答から少し修正しました．回答修正箇所は【回答修正】とつけました．
###回答
プログラム修正させて頂きました。
お困りの以下の２点を追加しました。
＞＞1.抽出先をF4に入力されたシートにすることができない。
以下のコードが抽出先シートを決定している箇所なので、この部分をF4のセルの値に変更しましょう。

Set Ns = Worksheets("抽出先シート")

＞＞2.抽出すべき項目と抽出しない項目をF6～F10、F12～F16に入力された条件に基づいて抽出できない。
ItemInc関数を新しく作り、その内部で抽出対象の有無を判定するようにしました。

###仕様
仕様ですが、以下のようにつくりました。
１．商品名と期間で抽出候補を抽出
２．抽出候補から[抽出][削除]の条件で絞り込んで、終了
２－１．[抽出][削除]が未入力の場合、１の条件に合うものを全て出力
２－２．[抽出][削除]どちらか一方入力の場合、１の条件からさらに絞り込み出力【回答修正】
２－３．[抽出][削除]が両方入力されている場合は、[抽出]のみ条件で出力
（[抽出][削除]両方入力することはないと思いますが・・・）

[抽出・削除]項目の考え方が正しいか分かりませんが、間違ってたら教えてください。

###プログラム
私が追加した箇所は[追加]or[変更]とコメントしておきました。
また、私なりに他のコードにもコメントをつけておきました。

Sub OneInstance01()
    Dim dstSheet      As Worksheet
    Dim Ns            As Worksheet
    Dim mPath         As String
    Dim buf           As String
    Dim i             As Long
    Dim j             As Integer
    Dim y             As Long
    Dim srcBook       As Workbook
    Dim Base          As Variant
    Dim Namae         As String
    Dim Sd            As Date
    Dim Ed            As Date
    Dim Included      As Variant '//[追加]抽出項目用
    Dim NotIncluded   As Variant '//[追加]抽出外項目用
    Dim WF            As Object
    Set WF = WorksheetFunction
    Set dstSheet = ThisWorkbook.Worksheets("抽出条件")
    'If Not Evaluate("=ISREF(抽出先シート!A1)") Then Sheets.Add.Name = "抽出先シート" '//[削除]【回答修正】
    'Set Ns = Worksheets("抽出先シート") '//[削除]
    '//F4で指定したシートがない場合は作成【回答修正】
    If Not Evaluate("=ISREF(" + dstSheet.Range("F4").Value + "!A1)") Then Sheets.Add.Name = dstSheet.Range("F4").Value '//[追加]
    Set Ns = Worksheets(dstSheet.Range("F4").Value) '//[追加]抽出先シートはセルF4の値に基づく
    
    Ns.UsedRange.Clear '//抽出先シートのデータを削除
    mPath = ThisWorkbook.Path & "\" '//マクロ保存しているファイルのフォルダパス
    buf = Dir(mPath & "*.xls*") '//フォルダ内のxlsファイル名をひとつ取得（マクロファイルも含む）
    y = 2
    With dstSheet
        Namae = .Range("B4").Value '//商品名
        Sd = .Range("B6").Value '//以降
        Ed = .Range("B7").Value '//以前
        Included = WorksheetFunction.Transpose(.Range("F6:F10")) '//[追加]抽出対象項目を配列化
        NotIncluded = WorksheetFunction.Transpose(.Range("F12:F16")) '//[追加]抽出対象外項目を配列化
    End With
    Do While buf <> "" '//取得したファイルをひとつずつ実行
        If buf <> ThisWorkbook.Name Then '//マクロファイルは処理しない
            Set srcBook = Workbooks.Open(mPath + buf) '//処理対象のワークブック
            Base = Intersect(srcBook.Worksheets("Sheet1").UsedRange, srcBook.Worksheets("Sheet1").Range("A:J")) '//値が存在する範囲を2次元配列化
            For i = 1 To UBound(Base, 1) '//Base配列の1次元インデックスの最大まで
                If Base(i, 1) = Namae And Base(i, 3) >= Sd And Base(i, 3) <= Ed And ItemInc(Included, NotIncluded, Base(i, 4)) Then '//[変更]
                    '//(右辺)WF.Index(Base, i, 0) -> Base(2次元配列)のi行目を配列で取得(第3引数が0だから)．
                    '//(左辺).Resize(, UBound(WF.Index(Base, i, 0))) -> Cells(y,2)を列方向に10列分拡張.
                    Ns.Cells(y, 2).Resize(, UBound(WF.Index(Base, i, 0))) = WF.Index(Base, i, 0)
                    y = y + 1
                End If
                DoEvents
            Next
            srcBook.Close False '//ワークブックを閉じる
        End If
        buf = Dir() '//次のxlsxファイルを取得(全て処理したら、while文終了)
        'Erase Base
    Loop
    Set dstSheet = Nothing
    Set srcBook = Nothing
    Set Ns = Nothing
    Set WF = Nothing
End Sub

'//[追加]項目が抽出対象ならTRUE、削除対象ならFALSE
Function ItemInc(Included As Variant, NotIncluded As Variant, Item As Variant) As Boolean
    Dim Bool As Boolean '//戻り値
    Dim Value As Variant
    
    '//項目が空ならFalse
    If Item = Empty Then
        ItemInc = False '//戻り値
        Exit Function '//処理終了
    End If
    
    If Join(Included, "") = "" And Join(NotIncluded, "") = "" Then
        '//[抽出、削除]未設定なら全部True
        ItemInc = True
        Exit Function
    ElseIf Join(Included, "") <> "" And Join(NotIncluded, "") = "" Then
        '//[抽出]の項目のみ設定されている場合
        Bool = False
        For Each Value In Included
            If Value = Item Then
                Bool = True
            End If
        Next Value
    ElseIf Join(Included, "") = "" And Join(NotIncluded, "") <> "" Then
        '//[削除]の項目のみ設定されている場合
        Bool = True
        For Each Value In NotIncluded
            If Value = Item Then
                Bool = False
            End If
        Next Value
    Else
        '//[抽出、削除]の両方に条件設定されている場合
        '//[抽出]項目のみの設定と同じ
        Bool = False
        For Each Value In Included
            If Value = Item Then
                Bool = True
            End If
        Next Value
    End If
    
    ItemInc = Bool '//戻り値

End Function

###補足
質問文に商品名はB列を参照しているとありますが、プログラムを見る限り、A列を参照しています。
以下のコードの「Base(i, 1) = Namae」の部分です。
Base(i, 1)はA列のi行目という意味ですので。

If Base(i, 1) = Namae And Base(i, 3) >= Sd And Base(i, 3) <= Ed Then

以上です。

Comments

[ichigo15]

KazuSakaさん

色々と教えていただき感謝します。
希望通りの結果になりました。

コメントが遅くなりまして申し訳ございません。
時間がかかってしまいましたが理解できました。
どのコードを修正すべきか丁寧に分かりやすく説明いただいたので助かりました。

とても勉強になりました。

[KazuSaka]

うまくいったみたいでよかったです！！