エクセルマクロで検索ボタンの作り方

質問

備品を管理するシステムを作ろうとしています。
下記項目のデータの入ったSheetが4つあります。(Sheet1～4)
Sheet5は検索シートにしたいと思います。
学校名
区分
機能別分類
品目類
取得年月日
品名
規格等
購入単価
購入先
廃棄年月日
保管場所
取得区分
それぞれ検索したいものを選んで、検索ボタンを押すとSheet1～Sheet4までのそれぞれ該当するものがピックアップされるようにしたいと思います。（例）品名の『ノート』を選択し、検索を押すとSheet1～4までの『ノート』が検索シートに全て表示される。
教えて下さい。

回答No.14

n-jun · ベストアンサー

もしかして、各シートを抽出した時に取得区分が空白になっていると言う事はないでしょうか？
その場合は、検索シートに転記されないですね。
ただ、取得区分に値があるのに転記されないとすると・・・？？？です。

以下は、取得区分に空白があっても対応できるよう変更しました。
差し替えてみて下さい。

Private Sub CommandButton1_Click()
Dim WS As Worksheet
Dim r As Range
Dim rr As Range, rs As Range
Dim v As Variant, vv As Variant
Dim i As Integer, j As Integer

Set WS = Worksheets("検索シート")
Set rr = WS.Range("B21")

vv = WS.Range("D2:D14").Value

For j = 1 To UBound(vv, 1)
If Not IsEmpty(vv(j, 1)) Then
GoTo nex:
End If
Next
End

nex:
WS.Range("A20").CurrentRegion.ClearContents
WS.Range("A20").Value = "学校名"
WS.Range("B20").Resize(, 12).Value = _
Worksheets("A").Range("A2:L2").Value

' 上と下の"A","B","C","D"は実際のシート名（学校名）に変更願います。

For Each v In Array("A", "B", "C", "D")

With Worksheets(v)

Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
r.AutoFilter
r.AutoFilter Field:=j - 1, Criteria1:=vv(j, 1)
Set rs = .Range(.[A3], .Cells(Rows.Count, "A").End(xlUp)).Resize(, 12).SpecialCells(xlCellTypeVisible)

If rs.Item(1).Row <> 2 Then
rs.Copy rr
rr.Offset(, -1).Resize(rs.Cells.Count / 12).Value = v
Set rr = rr.Cells(rs.Rows.Count, 1).Offset(1)
End If
r.AutoFilter
End With

Application.CutCopyMode = False
Next
End Sub

ＰＳ．実際の検索には学校名と通し番号は使えないですけど。

補足

できました！！学校名と通し番号の検索はできなくてもそんなに問題なかったので大丈夫です。この検索は、検索値が国語なら、国語の語句のあるSheetは抽出されます。ちなみに。区分が「国語」,機能別分類が「教材」というように複数の条件で、それに当てはまるものを検索するときはまたマクロを変えなくてはいけませんか？
【検索シート】
　　C　　　　　　D
１
２学校名
３通し番号
４区分　　　　　　国語
５機能別分類　　　教材
６品目類　　　　　
７取得年月日
８品名
９規格等
10購入単価
11購入先
12廃棄年月日
13保管場所
14取得区分

回答No.16

n-jun

AdvancedFilterでの一案。

C2～C14の項目をA5～M5に並べ替えて下さい。
注意は、C５～M5の項目名と各学校シートの項目名が一致している事。

検索値の入力は、６行目から１０行目まで対応してます。
必ず上の行から入れて下さい。
例）国語　且つ　教材
６行目の該当項目に　国語　と　教材　を入力します。

例）国語　又は　理科
該当する項目に　６行目に　国語　　７行目に理科　を入力して下さい

例）国語　又は　教材
６行目に　国語　７行目に　教材　です。

６行目の次に８行目に打ち込んだ場合、８行目は無視されます。
検索に有効だったものについては、薄緑色にセルが塗りつぶされます。
６行目を飛ばした場合は、その場で中断します。

新しくシートを作成して”検索シート２”として、コードに学校名を訂正し、
コマンドボタンを作成してから試してみて下さい。

Private Sub CommandButton1_Click()
Dim WS As Worksheet
Dim r As Range
Dim rr As Range, rs As Range
Dim kr As Range, kk As Range
Dim v As Variant, vv As Variant
Dim i As Integer, j As Integer

Set WS = Worksheets("検索シート２")
Set rr = WS.Range("B21")

Set kr = WS.Range("C5")
kr.Resize(6, 11).Interior.ColorIndex = 0

For Each kk In WS.Range("C6:C10")
If WorksheetFunction.CountA(kk.Resize(, 11)) > 0 Then
Set kr = Union(kr, kk)
Else
Exit For
End If
Next

Set kr = kr.Resize(, 11)
If kr.Cells.Count < 12 Then
MsgBox "検索値の入力でミスがあります" & vbLf & _
"中止します"
WS.Range("A20").CurrentRegion.ClearContents
Exit Sub
End If

kr.Interior.ColorIndex = 35
WS.Range("A20").CurrentRegion.ClearContents
WS.Range("A20").Value = "学校名"
WS.Range("B20").Resize(, 12).Value = _
Worksheets("A").Range("A2:L2").Value

' 上と下の"A","B","C","D"は実際のシート名（学校名）に変更願います。

For Each v In Array("A", "B", "C", "D")
With Worksheets(v)
Set r = .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp)).Resize(, 12)
r.AdvancedFilter xlFilterInPlace, kr, , False
Set rs = .Range(.[A3], .Cells(Rows.Count, "A").End(xlUp)).Resize(, 12).SpecialCells(xlCellTypeVisible)

If rs.Item(1).Row <> 2 Then
rs.Copy rr
rr.Offset(, -1).Resize(rs.Cells.Count / 12).Value = v
Set rr = rr.Cells(rs.Rows.Count, 1).Offset(1)
End If
.ShowAllData
End With
Application.CutCopyMode = False
Next
End Sub
うまくいけばいいですが。

回答No.15

n-jun

>複数の条件で、それに当てはまるものを検索するときはまたマクロを変えなくてはいけませんか？
複数の場合はもちろん変更は必要です。
ようは、いくつ条件を与えているかを判定し、その条件分だけ抽出しなければならないからです。
例えば、３つの条件までＯＫとしても、１つの時、２つの時、３つの時と、
判定し処理を行なわなければなりません。
或いは、オートフィルタではなくアドバンスドフィルタを用いて、
部分的に作り直しになるでしょうか。

そうゆう意味でも、ANo.4でお話ししたように、蓄積シートに対して
オートフィルタをかける方がいいと思います。
１つめの項目で絞り込み、２つめの項目で更に絞り込む。
そのような事が楽に出来ますよ。

あとは、質問者さんの決断によりますね。

お礼

たしかにオートフィルタをかけた方が楽ですよね・・・（汗）
とりあえず検索ボタンを作ることはおかげ様で完成させることができました。本当にありがとうございます。
n-junさんのご指摘どおり、蓄積シートよりオートフィルタをかけるやり方でいきたいと思います。また質問をすると思いますが、その時はよろしくお願いします。

回答No.13

n-jun

>検索値を入れても項目（学校名,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分）しか表示されず

>(希望する表示)
A20:M20に
学校名,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分

通し番号は書き漏れ？それともないの？

補足

すみません、"通し番号"は書き漏れていました。
今、A20:M20に
学校名,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分
が表示されています。しかし検索値があるのにもかかわらずA21:M21には何も表示されませんでした。
【検索シート】
　　C　　　　　　D
１
２学校名
３通し番号
４区分　　　　　国語
５機能別分類
６品目類
７取得年月日
８品名
９規格等
10購入単価
11購入先
12廃棄年月日
13保管場所
14取得区分
と入れています。国語が検索値です。
Ａ小学校には検索値があります。なのでA21:M21は
Ａ小学校,1,国語,教材,漢字スキル・・・・と表示させたいのですが・・

回答No.12

n-jun

>検索値を入れても項目しか表示されず
どこの項目に検索値を入れても表示されないのでしょうか？
或いは、特定の項目の時だけ起きるのでしょうか？

補足

どこの項目に入れても表示されませんでした。

回答No.11

n-jun

>Private Sub CommandButton1_Click()
>End Sub
>の下に貼り付けるのはあっていますか？
こちらでは問題なく実行できました。

>For Each v In Array("A小学校", "B小学校") ', "C小学校", "D小学校")であっていますでしょうか？
こちらのミスです。
For Each v In Array("A小学校", "B小学校", "C小学校", "D小学校")
この様にお願いします。

補足

For Each v In Array("A小学校", "B小学校", "C小学校", "D小学校")に直しましたが、検索値を入れても項目（学校名,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分）しか表示されず、抽出されたデータが出ませんでした。No.8のマクロでは抽出されたデータが表示されたのですが・・・

回答No.10

n-jun

こんな感じでしょうか？

Sub Test31()

Dim WS As Worksheet
Dim r As Range
Dim rr As Range, rs As Range
Dim v As Variant, vv As Variant
Dim i As Integer, j As Integer

Set WS = Worksheets("検索シート")
Set rr = WS.Range("B21")

vv = WS.Range("D2:D14").Value

For j = 1 To UBound(vv, 1)
If Not IsEmpty(vv(j, 1)) Then
GoTo nex:
End If
Next
End

nex:
WS.Range("A20").CurrentRegion.ClearContents
WS.Range("A20").Value = "学校名"
WS.Range("B20").Resize(, 12).Value = _
Worksheets("A").Range("A2:L2").Value

' 上と下の"A","B","C","D"は実際のシート名（学校名）に変更願います。
For Each v In Array("A", "B") ', "C", "D")

With Worksheets(v)

Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
r.AutoFilter
r.AutoFilter Field:=j - 1, Criteria1:=vv(j, 1)
Set rs = .Range(.[A3], .Cells(Rows.Count, "L").End(xlUp)).SpecialCells(xlCellTypeVisible)

If rs.Item(1).Row <> 2 Then
rs.Copy rr
rr.Offset(, -1).Resize(rs.Cells.Count / 12).Value = v
Set rr = rr.Cells(rs.Rows.Count, 1).Offset(1)
End If
r.AutoFilter
End With

Application.CutCopyMode = False
Next
End Sub

補足

さっそくありがとうございます！！
貼り付けてみたのですが、項目は表示されましたが、検索値があるのに何も表示されませんでした。
Private Sub CommandButton1_Click()
End Sub
の下に貼り付けるのはあっていますか？
' 上と下の"A","B","C","D"は実際のシート名（学校名）に変更願います。→AはA小学校,BはB小学校,CはC小学校,DはD小学校です。
Worksheets("A小学校").Range("A2:L2").Value
For Each v In Array("A小学校", "B小学校") ', "C小学校", "D小学校")であっていますでしょうか？

回答No.9

n-jun

"検索シート","A","B","C","D"は実際のシート名に変更されたのでしょうか？

>検索ボタンは検索シートに置いているのですが・・・うまくできませんでした。
どこの行で、どのようなエラーが出ているのかを提示して頂けないと、
回答は困難です。
或いは予定していない動き方をしているのか？など具体的に。

実際にはそちらのデータ形式にあわせて直す部分があると思います。
（条件形式等々）
１サンプルとして見て頂くしかないかも知れません。

補足

毎回すみません。コントロールツールボックスでボタンを作りVisual Basicで
Private Sub CommandButton1_Click()
End Sub
の下に貼り付けています。"検索シート","A","B","C","D"は実際のシート名に変更しました。ツールバー→実行→sub/ユーザーフォームの実行をクリックしました。検索結果はあっていたのですが、各シートの項目まで出てしまいます。検索値が無いシートには項目のみ出ています。検索値が無いシート、検索値の有るシートどちらも『項目』は表示したくないのですが、マクロのどこをどう変えればよいでしょうか。どうか教えて下さい。
(現在の表示)A20:M20に
学校名,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分
A21:M21に
ABC学校,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分
A22:M22に
ABC学校,1,国語,教材,漢字スキル・・・・と表示されました。
検索値の無い学校は『DEF学校,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分』と、項目のみ表示されました。
(希望する表示)
A20:M20に
学校名,通し番号,区分,機能別分類,品目類,取得年月日,品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分
A21:M21に
ABC学校,1,国語,教材,漢字スキル・・・・
検索値の無い学校は表示なし。にしたいと思います。

回答No.8

n-jun

細かな点は実際の環境に合わせて下さい。

Sub Test3()
Dim WS As Worksheet
Dim r As Range
Dim rr As Range, rs As Range
Dim v As Variant, vv As Variant
Dim i As Integer, j As Integer

Set WS = Worksheets("検索シート")
Set rr = WS.Range("B21")

vv = WS.Range("D2:D14").Value

For j = 1 To UBound(vv, 1)
If Not IsEmpty(vv(j, 1)) Then
GoTo nex:
End If
Next
End

nex:
WS.Range("A20").Value = "学校名"
WS.Range("B20").Resize(, 12).Value = _
Worksheets("A").Range("A2:L2").Value

' 上と下の"A","B","C","D"は実際のシート名（学校名）に変更願います。
For Each v In Array("A", "B", "C", "D")

With Worksheets(v)
Set r = .Range(.[A2], .Cells(Rows.Count, "L").End(xlUp))
r.AutoFilter
r.AutoFilter Field:=j - 1, Criteria1:=vv(j, 1)
Set rs = .Range(.[A3], .Cells(Rows.Count, "L").End(xlUp)).SpecialCells(xlCellTypeVisible)
rs.Copy rr
r.AutoFilter
End With

rr.Offset(, -1).Resize(rs.Cells.Count / 12).Value = v
Set rr = rr.Cells(rs.Rows.Count, 1).Offset(1)
Application.CutCopyMode = False
Next

End Sub
ご参考になれば。

補足

検索ボタンは検索シートに置いているのですが・・・うまくできませんでした。上記のマクロをコピーして貼り付けているのですが・・

回答No.7

n-jun

ところで、

>この備品台帳の第１案では、Sheet1～4の全てのデータを蓄積シートに集め、
>そこからオートフィルタで検索するという形式でした。
エクセルでSheetからSheetへの飛ばし方
http://okwave.jp/qa3341952.html
⇒こちらは、なしになったの？

補足

どちらの案も考え中です。まぎらわしくてすみません・・・
とりあえず２パターン作ろうと思っています。

回答No.6

n-jun

>検索シートにはC2:14にシート名(学校名),通し番号,区分,機能別,分類,品目類,取得年月日,
>品名,規格等,購入単価,購入先,廃棄年月日,保管場所,取得区分の項目名を入れています。
Ｃ列に項目名があることと、
>品名の『ノート』を選択し、
のつながりが見えないのですが、
『ノート』どこに表示されているのですか？
例えば、Ｄ列に打ち込むのですか？
或いはＤ列以降にすでに検索値は入っているのですか？

それとＣ２～Ｃ１４までデータがあれば、抽出されたデータはどこから
表示するのでしょう？
１５行目？　２０行目とか？？

補足

検索したい項目はC列、検索値はD列です。
例えば、Sheet1～4の中の『ノート』という品名を探す時・・・
　　　C　　　　　　　D
シート名(学校名)
通し番号
区分
機能別分類
品目　　　　　　　　ノート
類取得年月日
品名
規格等
購入単価
購入先
廃棄年月日
保管場所
取得区分
D列に検索値を入力します。
検索結果を表示させるのは20行目から表示させたいです。