複数のExcelファイルから特定のキーワードを含む行を抽出したいです。 調べて以下のように書いてみたのですが、キーワードに該当するものが複数あるはずなのに、一行しか抽出されませんでした。
複数のExcelファイルから特定のキーワードを含む行を抽出したいです。 調べて以下のように書いてみたのですが、キーワードに該当するものが複数あるはずなのに、一行しか抽出されませんでした。 お手数ですが、どなたかお知恵お借りできますと幸いです。 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 & "¥*.xlsx") 'フォルダ内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 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
Visual Basic・84閲覧
ベストアンサー
下記コードでは、FindNextの処理に移行しません。 Do Until LastRow <> Result.Row Or Result.Address = FirstAddress Set Result = .FindNext(Result) ※最初の検索でヒットした場合、下記条件を必ず満たします。 Result.Address = FirstAddress ----------------- 下記コードを試してください。 ※完全一致検索としています。実際の検索条件に合わせて修正してください。 Set Result = .Find(KEYWORD, LookIn:=xlValues, LOOKAT:=xlWhole) Sub Sample() Dim KEYWORD As String Dim FindPath As String Dim FindFileName As String Dim FindBook As Workbook Dim FindSheet As Worksheet Dim Result As Range Dim FirstAddress As String Dim PasteRow As Long Dim PasteSheet As Worksheet FindPath = "C:\" If Dir(FindPath, vbDirectory) = "" Then '指定のフォルダーがなければ処理終了 Exit Sub End If KEYWORD = InputBox("キーワードを入力してください") If KEYWORD = "" Then 'KEYWORDが空なら処理終了 Exit Sub End If Application.DisplayAlerts = False Application.ScreenUpdating = False PasteRow = 1 Set PasteSheet = Workbooks.Add.Worksheets(1) '##抽出処理 FindFileName = Dir(FindPath & "*.xlsx") 'フォルダ内XLSファイルを一つずつ開きながら処理 Do Until FindFileName = "" '見つかったブック(XLSXファイル)を開く Set FindBook = Workbooks.Open(FindPath & "\" & FindFileName) Windows(FindBook.Name).Visible = False 'ブック内のシートを一つずつ処理 For Each FindSheet In FindBook.Worksheets With FindSheet.Cells 'シート全体を検索対象に '条件に一致する最初のセルを検索 Set Result = .Find(KEYWORD, LookIn:=xlValues, _ LOOKAT:=xlWhole) If Not Result Is Nothing Then '最初に一致したセル番地を記憶 FirstAddress = Result.Address Do While Not Result Is Nothing '一致した行をコピー Result.EntireRow.Copy '指定の場所に貼り付け PasteSheet.Rows(PasteRow). _ PasteSpecial Paste:=xlPasteValues PasteRow = PasteRow + 1 Set Result = .FindNext(Result) If Result.Address = FirstAddress Then Exit Do Loop End If End With Next FindSheet FindBook.Close FindFileName = Dir Loop Set FindBook = Nothing Set Result = Nothing Set FindSheet = Nothing Set PasteSheet = Nothing Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
2人がナイス！しています
この返信は削除されました
質問者からのお礼コメント
ご教示いただいたコードで試してみたところ、欲しい結果を得られることができました。迅速にご回答いただき本当にありがとうございます！大変助かりました。
お礼日時：7/1 11:25
