トップ　>　汎用コード　>　データベースを検索し該当行を出力

'+++ 宣言セクション +++
Private Const SH_INDEX   As Long = 1        '検索対象のシート番号：1番左のシートは「1」、2つめは「2」
Private Const TARGET_COL As String = "A"    '検索列：検索対象の列
Private Const AND_OR     As Boolean = False '検索タイプ　True：and検索　False：or検索
Private Const KEYWORD    As String = "Excel,エクセル" 'キーワード　区切りはカンマ(,)

Private OWB        As Workbook  '出力用ブック
Private varKeyWord As Variant   'キーワード

Sub Search_and_output() '実行用マクロ
    Dim strDirPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strDirPath = .SelectedItems(1) 'フォルダ参照
    End With
    If strDirPath = "" Then Exit Sub 'フォルダ参照が「キャンセル」なら終了
    If Search_Main(strDirPath) Then MsgBox "検索終了", vbOKOnly + vbInformation
End Sub

Private Function Search_Main(ByVal strDP As String) As Boolean
    Dim lngSep As Long
    Dim strSep As String
    strSep = Application.PathSeparator  'パスセパレーター取得
    lngSep = InStrRev(strDP, strSep)    '位置取得
    If lngSep = 0 Then GoTo FIN_1       'フォルダパスにセパレーターがなければ終了
    
    '///対象フォルダ　存在確認
    If strSep = Right$(strDP, 1) Then strDP = Left$(strDP, Len(strDP) - 1)
    If Dir(strDP, vbDirectory) = "" Then GoTo FIN_1

    '///キーワードを配列として設定
    If InStr(1, KEYWORD, ",") = 0 Then
        ReDim varKeyWord(0 To 0)
        varKeyWord(0) = KEYWORD
    Else
        varKeyWord = Split(KEYWORD, ",")
    End If

    Application.ScreenUpdating = False
    Set OWB = Workbooks.Add             '新しいブックの挿入
    
    '///リストアップ処理開始
    If Not Search_Files(strDP & strSep) Then GoTo FIN_2
    
    With OWB.Worksheets(1)
        .UsedRange.Columns.AutoFit      '該当シートの列幅オートフィット
        .Range("A1").Value = "ヒット数：" & .Cells(.Rows.Count, TARGET_COL).End(xlUp).Row - 1
    End With
    OWB.Activate
    Set OWB = Nothing
    Application.ScreenUpdating = True
    Search_Main = True
Exit Function
FIN_1:
    MsgBox "選択したフォルダは対象外です", vbOKOnly + vbExclamation, "中止します"
Exit Function
FIN_2:
    Set OWB = Nothing
End Function

Private Function Search_Files(ByVal strDirPath As String) 'ファイル検索
    Dim f As Object, FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject") 'ファイルシステムオブジェクト
    With FSO.GetFolder(strDirPath)
        If .Files.Count = 0 Then 'ファイルがない場合は終了
            MsgBox "ファイルが見つかりません", vbInformation, "終了します"
            Exit Function
        End If
        For Each f In .Files
            If Right$(f.Name, 4) Like "xls?" Or Right$(f.Name, 4) = ".xls" Then
                If ThisWorkbook.Name <> f.Name Then
                    Call Target_Copy(strDirPath & f.Name)
                End If
            End If
        Next
    End With
    Search_Files = True
End Function

Private Sub Target_Copy(ByVal strFilePath As String) 'ブックを開き対象列を検索
    Dim AWB     As Workbook                 '検索対象ワークブック
    Dim rngArea As Range, rngUni As Range   '対象セル範囲/セル集合用
    Dim varData As Variant                  '対象セル範囲データ
    Dim i As Long, j As Long, c As Long
    Dim lngHit As Long, lngTotal As Long
    Dim f As Boolean
    Dim strAddress() As String
    
    Set AWB = Workbooks.Open(strFilePath)
    With AWB.Worksheets(SH_INDEX)
        Set rngArea = .Range(.Cells(1, TARGET_COL), .Cells(.Rows.Count, TARGET_COL).End(xlUp))
    End With
    If Not rngArea Is Nothing Then
        If rngArea.Cells.Count = 1 Then
            ReDim varData(1 To 1, 1 To 1)
            varData(1, 1) = rngArea.Value
        Else
            varData = rngArea.Value
        End If
        For i = 1 To UBound(varData)  'データ一覧
            f = False
            c = 0
            If AND_OR Then
                For j = 0 To UBound(varKeyWord)
                    If 0 < InStr(1, varData(i, 1), varKeyWord(j), vbTextCompare) Then
                        c = c + 1
                    End If
                Next
                If UBound(varKeyWord) = c - 1 Then f = True
            Else
                For j = 0 To UBound(varKeyWord)
                    If 0 < InStr(1, varData(i, 1), varKeyWord(j), vbTextCompare) Then
                        c = c + 1: Exit For
                    End If
                Next
                If 0 < c Then f = True
            End If
            If f Then '条件を満たした場合セルアドレスを取得
                lngHit = lngHit + 1: lngTotal = lngTotal + 1
                ReDim Preserve strAddress(1 To lngHit)
                strAddress(lngHit) = rngArea(i, 1).Address(False, False)
                If lngHit = 10 Then GoSub UNI
            End If
        Next
        If 0 < lngTotal Then
            GoSub UNI 'セル集合
            GoSub CPY 'コピー
        End If
    End If
    AWB.Close
Exit Sub
UNI: 'セル集合
    If lngHit = 0 Then Return
    With AWB.Worksheets(SH_INDEX)
        If rngUni Is Nothing Then
            Set rngUni = .Range(Join$(strAddress, ","))
        Else
            Set rngUni = Union(rngUni, .Range(Join$(strAddress, ",")))
        End If
    End With
    Erase strAddress
    lngHit = 0
    Return
Exit Sub
CPY: '行コピー＆貼り付け
    rngUni.EntireRow.Copy
    OWB.Worksheets(1).Cells(Rows.Count, TARGET_COL).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Set rngUni = Nothing
    Return
End Sub

書籍紹介本を執筆しました

知りたいがすぐわかる！　やりたいがすぐできる！
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」（Kindle版）
ユーザーフォームを扱えると、VBAでできることが大きく広がります！
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。
※　第1章～5章まで公開しています