エクセルのマクロで全シート複数条件検索

質問

• エクセルのマクロを使用して、全シートから複数項目で検索を行う方法について教えてください。
• 条件に合う項目の行を抽出し、新しいシートに表示することは可能でしょうか？
• 初心者ながら検索条件が複数ある場合や列ごとの条件指定ができずに困っています。

回答No.4

kagakusuki · ベストアンサー

以下の様なマクロは如何でしょうか。

Sub QNo9090316_エクセルのマクロで全シート複数条件検索()

Const ConditionSheetName As String = "Sheet3", FirstConditionRow As Long = 2, _
ConditionColumn As String = "B", SearchColumn As Long = 2, FirstOutputRow As Long = 1

Dim ConditionSheet As Worksheet, OutputSheet As Worksheet, _
LastConditionRow As Long, NotApplicable As Boolean, _
FindCell As Range, c As Range, i As Long, j As Long, k As Long

If IsError(Evaluate("ROW('" & ConditionSheetName & "'!A1)")) Then
MsgBox "検索条件が入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & ConditionSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set ConditionSheet = Sheets(ConditionSheetName)
LastConditionRow = ConditionSheet.Range(ConditionColumn & Rows.Count).End(xlUp).Row
If LastConditionRow <= FirstConditionRow Then
MsgBox ConditionSheetName & "の" & ConditionColumn _
& "列に検索条件が入力されておりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "条件未指定"
Exit Sub
End If

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

Sheets.Add After:=Sheets(Sheets.Count)
Set OutputSheet = Sheets(Sheets.Count)
i = FirstOutputRow
For Each c In ConditionSheet.Range(ConditionColumn & FirstConditionRow _
& ":" & ConditionColumn & LastConditionRow)
If c.Value <> "" Then
For j = 1 To Sheets.Count - 1
If j <> ConditionSheet.Index Then
k = 0
With Sheets(j).Cells(Rows.Count, SearchColumn).End(xlUp)
Set FindCell = .EntireColumn.Resize(.Row). _
Find(c.Value, , xlValues, xlWhole, xlByColumns, xlNext, False, False, False)
End With
NotApplicable = FindCell Is Nothing
Do Until NotApplicable
L = L + 1
k = FindCell.Row
If FindCell.Column = SearchColumn Then
FindCell.EntireRow.Copy
OutputSheet.Cells(i, 1).PasteSpecial _
xlPasteValuesAndNumberFormats, xlNone, False, False
i = i + 1
Set FindCell = Sheets(j).Cells.FindNext(After:=FindCell)
End If
NotApplicable = FindCell.Row <= k
Loop
End If
Next j
End If
Next c
If i = FirstOutputRow Then
Application.DisplayAlerts = False
OutputSheet.Delete
Application.DisplayAlerts = True
MsgBox "検索条件を満たしているデータは見つかりませんでした。" _
& vbCrLf & "マクロを終了します。", vbExclamation, "該当データ無し"
End If

Set c = Cells.Find("", ActiveCell, xlFormulas, _
xlPart, xlByRows, xlNext, False, False, False)
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

回答が遅れ申し訳ありません。
質問内容の動作実現に加え、未記入時のエラーへの分岐など
初心者の私にはとても扱いやすく感謝しています。
ありがとうございました。