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

質問

エクセルで全シートから複数項目で検索をかけ、条件に合う項目の行ごと
新しいシートに抽出結果として表示することは可能なのでしょうか。
初心者なりに考え、無様なコードではありますが、
検索条件が１つであれば、条件にあう行をすべて抽出することはできました。
ですが複数、または列ごと条件として指定することができず、難儀しております。
たとえば
Sheet1
　　　A　　　　B　　　　C　　　　D
1　　　　　 田中太郎　　 男　　　穏やか　
2　　　　　 鈴木次郎　　 女　　　うっかり
3　　　　　 山田三郎　　 女　　　怒りっぽい
4　　　　　 佐藤四郎　　 男　　　せっかち

Sheet2
　　　A　　　　B　　　　C　　　　D
1　　　　　 伊藤五郎　　 女　　　用心深い
2　　　　　 加藤六郎　　 男　　　ずぼら
3　　　　　 斎藤七郎　　 女　　　臆病
4　　　　　 後藤八郎　　 男　　　陽気

Sheet3
　　　A　　　　B　　　　C　　　　D
1 　　　　　【条件】
2　　　　　 加藤六郎
3　　　　　 鈴木次郎
4　　　　　 山田三郎
5　　　　　 後藤八郎

マクロ実行後↓
新しいシート
　　　A　　　　B　　　　C　　　　D
1　　　　　 加藤六郎　　 男　　　ずぼら
2　　　　　 鈴木次郎　　 女　　　うっかり
3　　　　　 山田三郎　　 女　　　怒りっぽい
4　　　　　 後藤八郎　　 男　　　陽気

といった具合にしたいと考えております。
この場合ですと、B列全体を条件としたり、
Sheet3の条件が入力されているセルすべてを検索条件として
渡すことはできるのでしょうか。
実際のシートでは、条件が１０個～１００個ほどあり、
シートごとに数はばらばらになっております。
どうかわかる方、お力をお貸しください。

回答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

お礼

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

回答No.5

Nouble

済みません、ちょっと汚します
お許しください。

此ってどうなのでしょう？
(まあ方向性だけでも如何でしょうか？)

ユーザー定義関数
Function 検索(ByVal キー As String, ByValレンギ As Range) As Range
Dim レンゲ As Range, レンゲ統合 As Range, ヒット数 As Long, センテンス As String
　ヒット数 = 0
　Set レンゲ = レンギ.Find _
　　 (What:=キー, LookIn:=xlValues, LookAt:=xlPart _
　　, SearchOrder:=xlByRows, SearchDirection:=xlNext _
　　, MatchCase:=False, MatchByte:=False)
　Do While レンゲ(ヒット数) Is Nothing
　　ヒット数 = ヒット数 + 1
　　Set レンゲ統合 = Union(レンゲ統合, レンゲ)
　　Set レンゲ = レンギ.FindNext(レンゲ)
　Loop
　レンゲ.Value = ヒット数
　Set レンゲ統合 = Union(レンゲ統合, レンゲ)
　Set 検索 = レンゲ統合
End Function

シート3のＣ１に
=INDEX(OFFSET(検索($B2,Sheet1:Sheet2!$B:$B),0,0,1,2),INT(COLUMN(A1)/2)+1,MOD(COLUMN(A1),2)+1)
必要なだけ横にフィル
フィルで選択された範囲を
必要なだけ縦にフィル
してください

ユーザー定義関数「検索」は
戻り値の最終項に
ヒット件数を入れたつもりです。
が、今回は使っていません

表示件数を超えた表示箇所
此への対応の処理に
使えるかも　知れません

まあそもそも
串刺し指定しているから
駄目かも知れません…
が、ね

もっとも
Evaluateを使えば
恐らくLoop不要で
もっと簡素化できる
の、ですが…
ね

スペシャルサンクス
OfficeTanaka
http://officetanaka.net/excel/vba/tips/index.htm

お礼

回答が遅れ申し訳ありません。
今回の質問で、一つの目的にも色々な
手法で実現できるということを知ることができました。
ありがとうございました。

回答No.3

Nouble

文字を扱っているので
やや不安ですが
c1に以下の式を入れ
右方向に横にずらっとフィル
縦にもフィル
してくださいね。
シート1，シート2，区別無く
横にフィルした件数分だけ
キーが重複していても
重複項を表示します。

=if(
　sumproduct(
　　　($Ｂ2=Sheet1!$b:$b)+($Ｂ2=Sheet2!$b:$b)
　)<=int(column((a1)/2)+1
　,""
　,offset(
　　chooce(
　　　mod(
　　　　small(
　　　　　index(
　　　　　　($Ｂ2=Sheet1!$b:　　$b)*(row(Sheet1!$b:$b)+0.01)
　　　　　　+($Ｂ2=Sheet2!$b:$b)*(row(Sheet1!$b:$b)+0.02)
　　　　　　+(($Ｂ2=Sheet1!$b:$b)+($Ｂ2=Sheet2!$b:$b))
　　　　　　*999999999999999)
　　　　　　,,)
　　　　　,int(
　　　　　　column(a1)/2)+1
　　　　　)
　　　　*100,100)
　　　,Sheet1!$b$1
　　　,Sheet2!$b$1)
　　,small(
　　　index(
　　　　($Ｂ2=Sheet1!$b:$b)*(row(Sheet1!$b:$b)+0.01)
　　　　+($Ｂ2=Sheet2!$b:$b)*(row(Sheet1!$b:$b)+0.02)
　　　　+(($Ｂ2=Sheet1!$b:$b)+($Ｂ2=Sheet2!$b:$b))
　　　　*999999999999999)
　　　,,)
　　,row(a1)-1)
　,1,1))

此方は重複非対応、
最初にヒットした項が読み出されます
c1に以下の式を入れ
D1にフィル
Ｃ１：Ｄ１を選択した状態で
必要なだけ下にフィルしてください

動作は
シート1，シート2に
各々ヒットする項があるか調べ
シート1にある場合は1を
シート2にある場合は2を
各々加えます
その上で更に1を加えます

シート1、シート2、
どちらにも無かった場合は
シート1で加えられる分の1も、
シート2で加えられる分の2も
加えられません
ので、最後に加えられる1のみ
計算結果は1
チョイス関数の結果は２つ目の""
です、

次に
シート1にあり、
シート2に無かった場合、
シート1を探す項の1が加えられ
シート2を探す項の2が加えられず
最後の1が加えられ
計算結果は2
チョイス関数の結果は
３つ目が選択され
オフセット関数により
シート１からセルが読み出されます、

次に
シート1に無く、
シート2にあった場合、
シート1を探す項の1が加えられず
シート2を探す項の2が加えられ
最後の1が加えられ
計算結果は3
チョイス関数の結果は
４つ目が選択され
オフセット関数により
シート2からセルが読み出されます、

次に
シート1にあり、
シート2にも あった場合、
シート1を探す項の1が加えられ
シート2を探す項の2が加えられ
最後の1が加えられ
計算結果は４
チョイス関数の結果は
５つ目が選択され
オフセット関数により
シート１からセルが読み出されます、

=if(
chooce(
　not(
　　iserror(
　　　match(
　　　　true()
　　　　,index(
　　　　　(($Ｂ2=Sheet1!$b:$b)
　　　　　,,)
　　　　,0)))

　+not(
　　iserror(
　　　match(
　　　　true()
　　　　,index(
　　　　　(($Ｂ2=Sheet2!$b:$b)
　　　　　,,)
　　　　,0)))*2
　+1
　,""
　,offset(
　　Sheet1!$a$1
　　,match(
　　　true()
　　　,index(
　　　　(($Ｂ2=Sheet1!$b:$b)
　　　　,,)
　　　,0)-1
　　,column(a1)-1
　　,1
　　,1)
　,offset(
　　Sheet2!$a$1
　　,match(
　　　true()
　　　,index(
　　　　(($Ｂ2=Sheet2!$b:$b)
　　　　,,)
　　　,0)-1
　　,column(a1)-1
　　,1
　　,1)
　,offset(
　　Sheet1!$a$1
　　,match(
　　　true()
　　　,index(
　　　　(($Ｂ2=Sheet1!$b:$b)
　　　　,,)
　　　,0)-1
　　,column(a1)-1
　　,1
　　,1))

如何でしょうか
お役に立てて居たならば幸いです。

因みに
VBAでするなら
ループ等回さず
.Findでした方が良いですよ

動作的に
ＶＢＡはインタプリタのようなもの
此に対して

組み込まれた関数や
シート関数は
コンパイル済み
の感覚

速度の差は
自明の理
ですよね

リソースの無駄遣い
ですよ

お礼

回答が遅れ申し訳ありません。
今回の質問で、一つの目的にも色々な
手法で実現できるということを知ることができました。
ありがとうございました。

回答No.2

ushi2015

こんにちは

Sub test()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim sh3 As Worksheet
　　Dim tsh1 As Worksheet
　　Dim tsh2 As Worksheet

　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　Set sh3 = Worksheets("Sheet3")
　　Set tsh1 = Sheets.Add(After:=Sheets(Sheets.Count))
　　Set tsh2 = Sheets.Add(After:=Sheets(Sheets.Count))

　　Intersect(sh1.UsedRange, sh1.Range("B:D")).Copy tsh2.Range("B2")
　　Intersect(sh2.UsedRange, sh2.Range("B:D")).Copy _
　　　　tsh2.Range("B" & Rows.Count).End(xlUp).Offset(1)

　　sh3.Range("B1").Copy tsh2.Range("B1")
　　tsh2.Range("C1:D1").Value = Array("Dummy1", "Dummy2")

　　tsh2.Range("B1:D1").Copy tsh1.Range("B1")

　　tsh2.Range("B1").CurrentRegion.AdvancedFilter _
　　　　Action:=xlFilterCopy, _
　　　　CriteriaRange:=sh3.Range("B1").CurrentRegion, _
　　　　CopyToRange:=tsh1.Range("B1:D1"), Unique:=False

　　tsh1.Rows(1).Delete

　　Application.DisplayAlerts = False
　　tsh2.Delete
　　With tsh1
　　　　.Sort.SortFields.Clear
　　　　.Sort.SortFields.Add Key:=Range("B1:B4"), _
　　　　　　SortOn:=xlSortOnValues, Order:=xlAscending, _
　　　　　　CustomOrder:="""," & _
　　　　　　　　Join(Application.Transpose(sh3.Range("B1").CurrentRegion), ",") & """", _
　　　　　　DataOption:=xlSortNormal
　　　　With .Sort
　　　　　　.SetRange .Parent.Range("B1").CurrentRegion
　　　　　　.Header = xlGuess
　　　　　　.MatchCase = False
　　　　　　.Orientation = xlTopToBottom
　　　　　　.SortMethod = xlPinYin
　　　　　　.Apply
　　　　End With
　　End With
　　Application.DisplayAlerts = True
End Sub

こんな感じでもどうでしょうか？

お礼

回答が遅れ申し訳ありません。
今回の質問で、一つの目的にも色々な
手法で実現できるということを知ることができました。
ありがとうございました。

回答No.1

real beatin（@realbeatin）

こんにちは。

' ' ///

Sub ReW9090316a()
Dim wksDst As Worksheet
Dim rngF As Range, rngK As Range, c As Range
Dim cn As Long
　　With Worksheets
　　　　Set wksDst = .Add(After:=.Item(.Count))　'　新しいシートを追加して変数に格納
　　End With
　　With Worksheets("Sheet3")　'　検索条件が設定されているシート名を正確に。""を忘れずに
　　　　Set rngK = .Range("B2:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
　　End With
　　Worksheets(Array("Sheet1", "Sheet2")).Select　'　検索対象シート名をArray関数内に列挙。""を忘れずに
　　Columns("B").Select
　　For Each c In rngK　'　検索条件範囲を For Each で総当たりループ
' ' 検索
　　　　Set rngF = Selection.Find( _
　　　　　　What:=c, After:=ActiveCell, _
　　　　　　LookIn:=xlValues, LookAt:=xlWhole, _
　　　　　　SearchOrder:=xlByRows, SearchDirection:=xlNext)
　　　　　　cn = cn + 1
　　　　If rngF Is Nothing Then　'　見つからなければ
　　　　　　c.Copy Destination:=wksDst.Cells(cn, 2)
　　　　Else　　　　　　　　　　'　検索にヒットしたら
　　　　　　rngF.EntireRow.Copy Destination:=wksDst.Cells(cn, 1)
　　　　End If
　　Next
　　wksDst.Select
End Sub

' ' ///

検索条件範囲を For Each で総当たりループしてそれぞれのキー毎に検索。
事前に複数の検索対象シートを作業グループにしておいて、
検索対象シートすべてのＢ列　を同時に選択状態にしておく。
検索にヒットしたら、行ごとコピペ、
見つからなければ、検索条件のセルをＢ列にコピペ。

特に指示がありませんでしたので、
重複はない、という扱いをしています。

以上、
色んな方法がありますけれど、
易しいExcel一般機能の組合わせだけで書いています。
手作業の工程をＶＢＡに書き起こしたようなものなので、
処理内容は比較的イメージし易いのではと。
ちなみに、データの統合作業の必要が想定される場合は、
各シートに共通のタイトル行を設けておくのが、データ管理の常道です。
タイトル行があれば、もっと色々な方法が選べますし、
ループしなくてももっと簡単に速く出来ると思いますし、
回答者としても手助けし易くなります。
今後のこととして、もしもシート設計を見直しされるような場合は、
改めて別件の質問としてお訊ねください。

以上です。

お礼

回答が遅れ申し訳ありません。
とても迅速かつ、言葉足らずの質問内容で
私のやりたかった動作を表現してくださり感謝しています。
ありがとうございました。