ＶＢＡでの検索抽出が出来るプログラムを作成したいで

質問

エクセルのsheet2～８のＡ2～Ｏ２までは項目（sheet2～8の項目は全て同じです。）、Ａ3～データが入力されています。
検索し、その結果の行すべてを抽出できるようにしたいのですがどのようにＶＢＡを作成すれば良いでしょうか？

検索条件は文字列で”注文業者名”、”注文番号”２つの項目で両方の項目または片方の項目で、検索ボックスにキーワードを入力し「検索開始」のコマンドボタンを押して検索が出来るようにしたいです。

漠然とした質問で申し訳ありません。
宜しくお願いします。

回答No.3

tom04 · ベストアンサー

No.2です。

補足を読ませてもらいました。

＞「注文業者」はE列、「注文番号」はB列になります。
＞そのばあい、回答いただいたコードのどの部分を訂正・削除すれば良いでしょうか？
に関してはコード内に説明を付けています。

＞またデータシート（sheet2～8）はシート名が入っている場合、コードの「For k = 2 To 8 '←Sheet2～Sheet8まで」はどのように訂正すれば良いでしょうか？
についてはSheet名は関係ありません。
前回のコードはSheet1にデータを表示させるためのコードで、
Sheet見出しの左から2番目Sheet～Sheet見出しの左から8番目のSheetまでをループしています。
どんなSheet名になっていても大丈夫です。

すなわち前回アップした画像の配置通りで、Sheet見出しの左から2番目～8番目のデータを
Sheet1（Sheet見出しの一番左側Sheet）に表示するのであれば
前回のコードでもちゃんと表示されると思います。

ただ補足により、オートフィルタをかける列がはっきりしましたので、
↓のコードに変更してみてください。
前回同様、標準モジュールですので、
Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample2()
Dim k As Long, endRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1") '←Sheet1の部分はSheet見出しの一番左側Sheetの実際のSheet名に！

'Sheet1のB1・B2に入力がない場合なにもしない
If wS.Range("B1") = "" And wS.Range("B2") = "" Then
MsgBox "検索データを入力してください"
Exit Sub
End If
'Sheet1の最終行取得
endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 4 Then '←Sheet1の項目行が4行目なので、データが5行目以降にある場合・・・
wS.Rows(5 & ":" & endRow).ClearContents 'Sheet1のデータのみ消去
End If
'Sheet見出しの左から2番目～8番目のSheetまで
For k = 2 To 8
'Sheet見出し、左からk番目Sheetの・・・
With Worksheets(k)
'「注文業者」の検索欄に入力がある場合・・・
If wS.Range("B1") <> "" Then
.Range("A2").AutoFilter field:=5, Criteria1:=wS.Range("B1") '←E列をSheet1のB1セル「注文業者」でフィルタを！
End If
'「注文番号」の検索欄の入力がある場合・・・
If wS.Range("B2") <> "" Then
.Range("A2").AutoFilter field:=2, Criteria1:=wS.Range("B2") '←B列をSheet1のB2セル「注文番号」でフィルタを！
End If
If .AutoFilter.FilterMode Then
'Sheet(k) 「Sheet見出し、左からk番目のSheetの最終行取得
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
'最終行が3行目以降であれば（フィルタをかけたあとでもデータが表示されていれば）
If endRow > 2 Then
'Sheet(k)の表示されているA3～O列最終行を、Sheet1のA列最終行の1行下へコピー＆ペースト
Range(.Cells(3, "A"), .Cells(endRow, "O")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
'Sheet(k)のオートフィルタ解除
.AutoFilterMode = False
End If
End With
'次のSheetへ
Next k
End Sub

なんとかご希望通りに動くでしょうか？m(_ _)m

お礼

ありがとうございました！大変助かりました。

回答No.2

tom04

こんばんは！

＞漠然とした質問で申し訳ありません。

たしかに必要なコト（オートフィルタをかける列）が書いてないので・・・
本来であれば必要のないコードが増えてしまいました。
注文業者・注文番号の列が判ればもっと短くなります。
その列が判らないためコード内でそれぞれの列番号を取得しています。
Sheet1のA1・A2セルのは各Sheetの項目名と同じにしておいてください。

↓の画面で上側がSheet1でB1セルに「注文業者」を・B2セルに「注文番号」を入力して検索するようにしてみました。
尚、Sheet1は画像のように4行目が項目行で5行目以降にデータを表示するようにしています。

標準モジュールの↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim k As Long, c As Range, endRow As Long, r As Range, wS As Worksheet
Set wS = Worksheets("Sheet1")

'Sheet1のB1・B2に入力がない場合なにもしない
If wS.Range("B1") = "" And wS.Range("B2") = "" Then
MsgBox "検索データを入力してください"
Exit Sub
End If

'Sheet1の最終行取得
endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 4 Then '←Sheet1の項目行が3行目なので、データは4行目以降にある場合・・・
wS.Rows(5 & ":" & endRow).ClearContents 'Sheet1のデータのみ消去
End If
For k = 2 To 8 '←Sheet2～Sheet8まで
With Worksheets(k)
'「注文業者」の列を取得（列が判っている場合は不要）
If wS.Range("A1") <> "" Then
Set c = .Rows(2).Find(what:=wS.Range("A1"), LookIn:=xlValues, lookat:=xlWhole)
End If
'「注文番号」の列を取得（列が判っている場合は不要）
If wS.Range("A2") <> "" Then
Set r = .Rows(2).Find(what:=wS.Range("A2"), LookIn:=xlValues, lookat:=xlWhole)
End If
'「注文業者」の検索欄に入力がある場合・・・
If wS.Range("B1") <> "" Then
.Range("A2").AutoFilter field:=c.Column, Criteria1:=wS.Range("B1") '←fieldの部分に列番号を！
End If
'「注文番号」の検索欄の入力がある場合・・・
If wS.Range("B2") <> "" Then
.Range("A2").AutoFilter field:=r.Column, Criteria1:=wS.Range("B2") '←fieldの部分の列番号を！
End If
If .AutoFilter.FilterMode Then
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 2 Then
Range(.Cells(3, "A"), .Cells(endRow, "O")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
.AutoFilterMode = False
End If
End With
Next k
End Sub

＞検索開始」のコマンドボタンを押して・・・
とありますので、Sheet1のコマンドボタンを配置して上記コードでも動けばそのままでOKなのですが、
別Sheetを操作するようにしていますので、万一動かない場合は
上記コードは標準モジュールのままにしておいて、コマンドボタンのコードを↓にしてみてください。

Private Sub CommandButton1_Click()
Call Sample1
End Sub

長々と失礼しました。m(_ _)m

お礼

ありがとうございました！大変助かりました。

補足

回答ありがとうございます！！

「注文業者」はE列、「注文番号」はB列になります。
そのばあい、回答いただいたコードのどの部分を訂正・削除すれば良いでしょうか？

またデータシート（sheet2～8）はシート名が入っている場合、コードの「For k = 2 To 8 '←Sheet2～Sheet8まで」はどのように訂正すれば良いでしょうか？

度々申し訳ありませんが、宜しくお願い致します。

回答No.1

某HN クロメート(Chromate)（@CoalTar）

VBAは趣味程度です

一 マクロの記録をとる
0. 条件表の作成
1. Sheet1において
2. A4セルを選択し、[Ctrl]+[Shift]+[*] 削除
3. データ - フィルタ - フィルタオプションの設定 でSheet2で行う
4. もう一度、データ - フィルタ - フィルタオプションの設定 でSheet3で行う
5. タイトル行は消す

二 [Alt]+[F11]VBEで編集
[Ctrl]+[↑] のような挿入位置を相対的に考える

三 For～Next 構文で シート名を変更しつつ繰り返す

といった方法が単純かな。

下記 二まで

Sub Macro2()
Dim n As Long
　 Sheets("Sheet1").Select
　 Range("A4").CurrentRegion.Clear

　 Sheets("Sheet2").Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
　 CriteriaRange:=Range("A1:B2"), CopyToRange:=Range("A4"), Unique:=False

　 n = Range("A" & Rows.Count).End(xlUp).Row + 1
　 Sheets("Sheet2").Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
　 CriteriaRange:=Range("A1:B2"), CopyToRange:=Range("A" & n), Unique:=False
　 Rows(n).Delete Shift:=xlUp
End Sub

お礼

ありがとうございました！参考にさせて頂きます。