Excel_VB:条件を入れてデータ抽出

質問

別シートにあるデータベースを
特定のセルに抽出条件となるwordを入力すると別シートから情報を返すマクロを作成しています。

簡易的なコードがございましたらご教授ください。
何卒よろしくお願いいたします。

詳細
▼検索条件の単語を入力するセル
　１～3を複数条件で抽出

1_バンド名（B6）
2_曲名（B8）
3_アルバム名（B10）

▼別シートのデータベース
1行目はタイトルを入力しています。
バンド名（A列）
曲名（B列）
アルバム　（C列）　　　
時間（D列）
ジャンル（E列）
メディア（F列）
備考（G列）

▼情報を返すセル
バンド名（F15）
曲名（G15）
アルバム　（H15）　　　
時間（I列）
ジャンル（J15）
メディア（K15）
備考（L15）

回答No.3

K Kazz（@JazzCorp） · ベストアンサー

Option Explicit
Sub MusicStart()
Const xName = "Sheet1" 'ソース
Const xMode = "*" '検索条件：部分一致："*"、完全一致：""
Application.ScreenUpdating = False
If (ActiveSheet.Name <> xName) Then
With Worksheets(xName)
If (.UsedRange.Rows.Count > 1) Then
'このクリアはイヤラシイ！、ドコまで？？
' Range("F15:L15").ClearContents
If Not IsEmpty(Range("B6")) Then _
.Range("A1").AutoFilter field:=1, Criteria1:=xMode & Range("B6").Value & xMode
If Not IsEmpty(Range("B8")) Then _
.Range("A1").AutoFilter field:=2, Criteria1:=xMode & Range("B8").Value & xMode
If Not IsEmpty(Range("B10")) Then _
.Range("A1").AutoFilter field:=3, Criteria1:=xMode & Range("B10").Value & xMode
.AutoFilter.Range.Offset(1).Copy
Range("F15").PasteSpecial
.Range("A1").AutoFilter
Columns("F:H").AutoFit
End If
End With
Else
MsgBox ("別のシートで実行してネ！")
End If
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。

回答No.4

hallo-2007

簡易的なコードがございましたらご教授ください。
何卒よろしくお願いいたします。

ということですので
http://www.eurus.dti.ne.jp/yoneyama/Excel/filter3.htm
でエクセルのフィルターオプションを勉強してみて下さい。
最後にVBAのコードがあります。
抽出するためのシート
6行目に
バンド　名曲名　アルバム名
7行名に
抽出したいバンド名など

15行名に表示したい項目名

マクロの記録を実行すると
Sub Macro2()
Sheets("Sheet1").Columns("A:F").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A16:C18"), CopyToRange:=Range("A15:F15"), Unique:=False
End Sub
みたいな感じになると思います。
わずか1行で済みます。

お礼

ありがとうございます。

回答No.2

K Kazz（@JazzCorp）

＞▼検索条件の単語を入力するセル
　１～3を複数条件で抽出
イワユル、キーワード検索だよね？
それと、検索結果は複数、がありうるし、ないこともある。結果を出すセルのクリア範囲はどうするの？？

お礼

ご対応ありがとうございます！！
はい。キーワード検索です。
結果はF15:L15より複数結果の際、下行に1つずつ結果を返すイメージです。
もちろん結果が出ない場合もあります。データベースのレコードは600ほどです。お答えになっていますでしょうか、、、？
>１～3を複数条件で抽出
>イワユル、キーワード検索だよね？
>それと、検索結果は複数、がありうるし、ないこともある。結果
>を出すセルのクリア範囲はどうするの？？

回答No.1

keithin

どうして「結果が一つしかない」前提なんですか。

sub macro1()
　application.screenupdating = false
　range("15:65536").clearcontents
　if range("B6") <> "" then _
　　worksheets("別シート").range("A1").autofilter field:=1, criteria1:=range("B6").value
　if range("B8") <> "" then _
　　worksheets("別シート").range("A1").autofilter field:=2, criteria1:=range("B8").value
　if range("B10") <> "" then _
　　worksheets("別シート").range("A1").autofilter field:=3, criteria1:=range("B10").value
　worksheets("別シート").autofilter.range.offset(1).copy range("F15")
　worksheets("別シート").autofiltermode = false
　application.screenupdating = true
end sub

お礼

ありがとうございます！