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

データベースを検索し該当行を出力簡易検索

指定フォルダの全ブックを対象に、任意のシートの任意の列を一括検索し、検索結果を出力するマクロです。
書式が統一されたデータベースファイルを検索対象として想定しています。

マクロを実行すると、フォルダ参照ダイアログが表示されます。
フォルダを選択すると、そのフォルダ内の、全てのExcelブックの指定したシートの指定した列を対象に、検索を開始します。
検索がヒットした場合、ヒットした行をまとめてコピーし、新規ブックに出力します。

・検索対象とするシートや列は定数で指定します
・検索キーワードは定数で設定します
 ※複数のキーワードを設定する場合はカンマで区切ります
 ※キーワードの個数上限は設けていませんが最大10位を目安にすると良いと思います
・検索タイプはand検索かor検索で 定数で指定します
・検索では全角・半角/大文字・小文字/ひらがな・カタカナを区別しません

■参考画像
・フォルダ内のデータベース1.xlsxとデータベース2.xlsxが対象
・各ブックの1枚目のシートのA列が検索対象 (データ個数は各ブック5000)
・検索キーワードは「藤」と「子」で両方を含むものを検索(and検索)
※画像内の個人情報はダミーデータです 





サンプルコード

コードの貼り付け場所

'+++ 宣言セクション +++
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

より高度な検索マクロやシステムをご希望の場合はご相談ください。
・キーワード入力に複数のテキストボックスを用いる
・AND/OR/NOTに対応
・優先検索に対応
・全角・半角/大文字・小文字/ひらがな・カタカナを区別
・複数のシートや列を検索対象にする

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

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


ページトップへ戻る

Excel 汎用コード



Word 汎用コード

Copyright(C) 2009- 坂江 保 All Rights Reserved.