VBAを使用したデータの抽出について

質問

sheet1に下記のような（例）データベースがありＡ～Ｎ列までデータが入力されています。

Ａ　Ｂ　　Ｃ　　Ｄ　 Ｅ　　 Ｆ　　Ｇ　　Ｈ　Ｉ　Ｊ　 Ｎ
1　○○様　○○　 2名 　車　 　可 東京 *** *** *** 2015/7/1
2　○○様　××　 3名　 車　 不可 埼玉 2015/8/1
3　○○様　×□　 2名　 電車　不可　愛知 2015/8/12
4　○○様　□□　 4名　 バス　 可　 新潟 2015/7/13
5　○○様　○×　 3名　 バス　 可　 宮城 2015/6/1
6　○○様　○□　 4名　 車　 不可　大阪 2015/8/21
7　○○様　□○　 2名　 バス　 可　 山梨 2015/8/7

「sheet1」B列のデータを元にして、別シート（sheet2）のA2列に抽出したいもの（例：バス）を入力し、
フォームボタン（例：抽出）で検索し、抽出された結果のsheet1のA列～G列、N列のみ（H列～J列は不要）をSheet2のA11以下へ表示したいと考えています。

Ａ　 Ｂ　 Ｃ　　Ｄ　 Ｅ 　 Ｆ　 Ｇ　　　Ｎ
4　○○様　□□　 4名　 バス　 可　 新潟 2015/7/13
5　○○様　○×　 3名　 バス　 可　 宮城 2015/6/1
7　○○様　□○　 2名　 バス　 可　 山梨 2015/8/7

どのようなVBAのコードを使用すれば良いでしょうか。

宜しくお願いします。

回答No.1

kagakusuki

御質問文の例では、Sheet1にはいきなり1行目からデータが入力されている様に書かれていますが、実際にはA列に1と入力されているセルはA1セルなどではなく、そのA列に1と入力されている行の上には何らかの項目名が入力されている行があるのではないでしょうか?
　御質問の件の様なVBAのマクロを作るためには、何行目からデータが入力されているのかという事に関する情報も必要になる場合が多いので、実際のデータが何行目から入力されているのかという事も忘れずに説明しておく様にして下さい。
　尚、いきなり1行目からデータが入力されている場合には処理が面倒になりますので、いきなり1行目からデータを入力する事はなるべく避けた方が宜しいかと思います。

　それで、実際のデータが何行目から入力されているのかという事が不明なため、取り敢えず仮の話として、Sheet1において項目名が入力されている行は2行目であり、実際のデータは3行目以下に入力されているものとします。
　その場合、色々なやり方がありますが、一例としてオートフィルターを利用した方法では次の様なVBAマクロとなります。

Sub QNo9008324_VBAを使用したデータの抽出について()

Dim CopySheet As Worksheet, PasteSheet As Worksheet, _
ItemRow As Long, LastRow As Long, PasteCell As Range, _
CopyColumn As String, UnwantedColumn As String, _
ReferenceColumn As String, myCriteria As Variant, _
CriteriaCell As Range

Set CopySheet = Sheets("Sheet1") '元データが入力されているシート
Set PasteSheet = Sheets("Sheet2") '貼付け先のシート
CopyColumn = "A:N" 'コピーする元データが入力されている列の範囲
UnwantedColumn = "H:J" 'コピーする必要のない列の範囲
ReferenceColumn = "E" '抽出したいものが入力されている列
ItemRow = 2 ' 元データの表の項目欄の行番号
Set PasteCell = PasteSheet.Range("A11") '貼付け先のセル範囲の中で最も左上にあるセル
Set CriteriaCell = PasteSheet.Range("A2") '抽出したいものが入力されているセル

myCriteria = CriteriaCell.Value
If myCriteria = "" Then
MsgBox "抽出すべき項目が指定されていないため処理を行う事が出来ません。" & _
"マクロを一旦、終了しますので、抽出すべき項目を" _
& PasteCell.Parent.Name & "!" & PasteCell.Address(False, False) & _
"セルに入力してから本マクロによる処理をやり直して下さい。", _
vbExclamation, "抽出項目未設定"
Exit Sub
End If
LastRow = CopySheet.Range(ReferenceColumn & Rows.Count).End(xlUp).Row
If LastRow <= ItemRow Or WorksheetFunction.CountIf(CopySheet. _
Range(ReferenceColumn & ItemRow & ":" & ReferenceColumn & LastRow), _
myCriteria) = 0 Then
MsgBox "抽出すべきデータがありません。", vbInformation, "データ無し"
Exit Sub
End If

Application.ScreenUpdating = False
PasteCell.Resize(PasteSheet.Cells.SpecialCells(xlCellTypeLastCell).Row - PasteCell.Row + 1, _
Columns(CopyColumn).Columns.Count - Columns(UnwantedColumn).Columns.Count).ClearContents
With CopySheet
If .AutoFilterMode Then CopySheet.Cells.AutoFilter
.Columns(UnwantedColumn).EntireColumn.Hidden = True
.Range(ReferenceColumn & ItemRow & ":" & ReferenceColumn & LastRow). _
AutoFilter Field:=1, Criteria1:=myCriteria
Intersect(.Columns(CopyColumn), .Rows(ItemRow & ":" & LastRow)).SpecialCells(xlCellTypeVisible).Copy
PasteCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
.Cells.AutoFilter
.Columns(UnwantedColumn).EntireColumn.Hidden = False
End With
Application.ScreenUpdating = True

End Sub

　尚、もしSheet1において項目名が入力されている行が2行目ではなかった場合には、上記のVBAの構文中の

ItemRow = 2

という箇所の2という数値の部分を、実際の項目名が入力されている行の行番号に合わせて修正して下さい。