複数のエクセルファイルから特定の語を含む行を抽出したい

質問

エクセルで作成した複数の部品リストがあります。
特定の単語(型番)を含む行を抽出して、その行だけ集めたリストを作成したいのですが、そのような便利なツールはありませんか。
できあがるファイルはエクセルでもテキストでも構いません。
部品リストファイルは膨大な数があるので、ファイル毎そのツールにかけるのではなく、フォルダを指定して一気に処理できるとありがたいです。

回答No.1

Masa2072 · ベストアンサー

拙作ですが参考になれば
FindPathで指定されたフォルダに保存されたブック（XLSファイル）を検索し、キーワードに一致する行を新規ブックにコピーします。

Sub Sample()
　　Dim KEYWORD As String　　　'検索時のキーワード
　　Dim FindPath As String　　　　'検索対象フォルダのパス
　　Dim FindFileName As String　 '検索対象ブックのファイル名
　　Dim FindBook As Object　　　 '検索対象ブック
　　Dim FindSheet As Object　　 '検索対象のシート
　　Dim Result As Object　　　　　'検索に一致したセル
　　Dim LastRow As Long　　　　　'最後に一致した行番号
　　Dim FirstAddress As String　'最初に一致したセルのアドレス
　　Dim PasteRow As Long　　　　'貼り付け先行番号
　　Dim PasteSheet As Object　　'貼り付け先シート
　　Dim i As Long

　　Application.DisplayAlerts = False　 '警告メッセージの抑制
　　PasteRow = 1　　'貼り付け先行番号をリセット
　　Set PasteSheet = Workbooks.Add.Sheets(1)

　　'##キーワードの取得
　　KEYWORD = InputBox("キーワードを入力してください")
　　If KEYWORD = "" Then
　　　　'KEYWORDが空なら処理終了
　　　　GoTo 終了処理
　　End If

　　FindPath = "C:\"

　　If Dir(FindPath, vbDirectory) = "" Then
　　　　'指定のフォルダーがなければ処理終了
　　　　GoTo 終了処理
　　End If

　　'##抽出処理
　　FindFileName = Dir(FindPath & "*.xls")
　　'フォルダ内XLSファイルを一つずつ開きながら処理
　　Do Until FindFileName = ""
　　　　Set FindBook = Workbooks.Open(FindPath & FindFileName)　 '見つかったブック(XLSファイル)を開く
　　　　Windows(FindBook.Name).Visible = False
　　　　'ブック内のシートを一つずつ処理
　　　　For Each FindSheet In FindBook.Worksheets
　　　　　　With FindSheet.Cells　 'シート全体を検索対象に
　　　　　　　　Set Result = .Find(KEYWORD, LookIn:=xlValues)　 '条件に一致する最初のセルを検索
　　　　　　　　If Not Result Is Nothing Then
　　　　　　　　　　FirstAddress = Result.Address '最初に一致したセル番地を記憶
　　　　　　　　　　LastRow = Result.Row　'直前に一致した行を記憶
　　　　　　　　　　Do
　　　　　　　　　　　　FindSheet.Rows(Result.Row).Copy　　'一致した行をコピー
　　　　　　　　　　　　PasteSheet.Rows(PasteRow).PasteSpecial Paste:=xlPasteValues '指定の場所に貼り付け
　　　　　　　　　　　　PasteRow = PasteRow + 1 '貼り付け先を一つ下に

　　　　　　　　　　　　'1行で複数一致した場合に無視する
　　　　　　　　　　　　'別の行になるか、最初に一致したセルになるまで検索を繰り返す
　　　　　　　　　　　　Do Until LastRow <> Result.Row Or Result.Address = FirstAddress
　　　　　　　　　　　　　　Set Result = .FindNext(Result)
　　　　　　　　　　　　Loop
　　　　　　　　　　　　LastRow = Result.Row　'直前に一致した行を記憶

　　　　　　　　　　Loop While Not Result Is Nothing And Result.Address <> FirstAddress
　　　　　　　　End If
　　　　　　End With
　　　　　　i = 0
　　　　Next
　　　　FindBook.Close　　'開いたブックを閉じる
　　　　FindFileName = Dir
　　Loop

終了処理:
　　Set FindBook = Nothing
　　Set Result = Nothing
　　Set FindSheet = Nothing
　　Set PasteSheet = Nothing
　　Application.DisplayAlerts = True
End Sub

お礼

回答ありがとうございます。
確認するのに時間がかかりそうなのと、他に回答が付きそうがないので一旦締め切ります。
確認した上で疑問点など出てきたら、改めて質問しますので、その際はよろしくお願いします。