Excelのマクロで検索条件と一致する複数結果を全て抽出する方法について

初めて質問させていただきます。
詳しい方、教えていただけませんでしょうか。

表示用シートのセルA1に営業部コードを入力すると、その営業部管下の支社所属社員の情報を、元データシートから抽出して、画像のように内容別の表へそれぞれ表示させるという仕組みを作りたいと思っています。

元データシートには、
営業部コード　支社名　社員名　入社年月　個人件数　個人金額　法人件数　法人金額　獲得P…
といった感じで、表示用シートの元になるデータを社員1人につき1行で全データを入力してあります。

営業部によって表示される人数（最低3名から最高30名）も違うので、オレンジ色の項目行の下は、抽出した件数によって自動で罫線のある行が追加され、内容が表示されるようにしたいです。

このようなマクロ・VBAの作成方法を教えてください。
会社ではExcel2010を使用しています。
宜しくお願いします。

※欲を言うと、A1の営業部コート入力後、隣に抽出ボタンを作ってそれを押すと抽出、さらに隣にクリアボタンを作って、それを押すと抽出したデータをクリアする、という風にできるとありがたいです。

No.1 回答者： hallo-2007 回答日時： 2015/06/09 22:03

昨日も同じような質問があったので

一例です。
　　　　　A　　　　　B　　　　C　　　　D　　　　E
１
２　　営業部コード　　
３
４
５　　支社名　　社員名　　入社年月　個人件数　個人金額
と項目名を張り付けてじゅんびします。
シートの名前のタブを右クリック
コードの表示をクリック
VBエディターが起動するので

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address="$A$3" Then
Sheets("元データ").Columns("A:H").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A２:A３"), CopyToRange:=Range("A5:E5"), Unique:=False
Endi If
End Sub

を張り付けて閉じる。
A3セルに　コードを入力してEnterを押すだけで、ご希望のデータが抽出されます。
枠を付けたければ、条件付き書式で設定できます。

詳しくは、こちらの質問に書いておきました。
https://oshiete.goo.ne.jp/qa/8998094.html

この回答へのお礼

早速教えていただきありがとうございます。

教えていただいた内容で実行してみたのですが、この内容だと成績関連のデータを抽出すると、データがそのまま表示されてしまい、次の表のキャンペーン関連の内容が表示できませんでした。

30人所属している営業部のコードをA1に入力したら、成績関連のデータを30行、1・2行あけてキャンペーン関連のデータを30行、1・2行あけて資格関連のデータを30行表示させ、A1のコードを消したら、抽出したデータもクリアされて成績・キャンペーン・資格の項目行だけが残る。5人所属している営業部のコードを入力したら、成績関連のデータを5行…
という風に、入力した営業部コードの抽出結果にあわせて、その都度行数を変化させて表示させたいのですが、難しいでしょうか。

お礼日時：2015/06/09 23:50

No.2 回答者： hallo-2007 回答日時： 2015/06/13 09:17

>入力した営業部コードの抽出結果にあわせて、その都度行数を変化させて表示させたいのです

出来ないことはないですよ。VBAの力をかります。
そこで、考え方ですが。
最大に人数で項目を配置して、抽出を行って、不要な部分を非表示にしてしまう方が
作りやすいと思います。
しかし、抽出の結果で、項目の行が上下する表示は如何でしょうか？
結構、見づらいものになりそうな気がします。

成績関連、キャンペーン関連、資格関連で表示される項目が違うだけですよね。
一案ですが
C3セルに　成績関連、キャンペーン関連、資格関連　と選択できるように入力規則を設定して
先のアドバンスフィルターで全ての項目を表示させる。
その下に以下のコードを追加して

If Target.Address="$C$3" Then
IF Target.Value="成績関連" Then
Columns("A:H").EntireColumn.Hidden = False
Columns("F:H").EntireColumn.Hidden = True
End If

IF Target.Value="成績関連" Then
Columns("A:H").EntireColumn.Hidden = False
Columns("D:F").EntireColumn.Hidden = True
End If
・・・・
End If

必要な列が表示されたり、非表示になったりしたら
どうでしょうか。

No.3 回答者： tom04 回答日時： 2015/06/14 22:50

こんばんは！

まず標準モジュールに↓のコードをコピー＆ペーストしてください。

Sub 抽出()
Dim i As Long, k As Long, myRow As Long, c As Range
Dim lastRow As Long, lastCol As Long, wS As Worksheet
Dim myAry1 As Variant, myAry2 As Variant
Set wS = Worksheets("元データ")
myAry1 = Array("成績関連", "キャンペーン関連", "取得資格関連")
Application.ScreenUpdating = False
With Worksheets("表示用")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
lastCol = .UsedRange.Columns.Count
Range(.Cells(2, "A"), .Cells(lastRow, lastCol)).Clear
End If
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
wS.Range("A1").AutoFilter field:=1, Criteria1:=.Range("A1")
For i = 1 To 3
myRow = .Cells(Rows.Count, "A").End(xlUp).Row + 3 '←2行あける//
.Cells(myRow, "A").Resize(, 2).Merge
.Cells(myRow, "A") = myAry1(i - 1)
If wS.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
wS.Range("B1").Resize(, 3).Copy .Cells(myRow + 1, "A")
Range(wS.Cells(2, "B"), wS.Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy
.Cells(myRow + 2, "A").PasteSpecial Paste:=xlPasteAll
Select Case i
Case 1: myAry2 = Array("個人件数", "個人金額", "法人件数", "法人金額")
For k = 0 To UBound(myAry2)
.Cells(myRow + 1, Columns.Count).End(xlToLeft).Offset(, 1) = myAry2(k)
Set c = wS.Rows(1).Find(what:=myAry2(k), LookIn:=xlValues, lookat:=xlWhole)
Range(wS.Cells(2, c.Column), wS.Cells(lastRow, c.Column)).SpecialCells(xlCellTypeVisible).Copy
.Cells(myRow + 2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll
Next k
.Cells(Rows.Count, "A").End(xlUp).CurrentRegion.Borders.LineStyle = xlContinuous
Case 2: myAry2 = Array("獲得P", "入賞まで残P")
For k = 0 To UBound(myAry2)
.Cells(myRow + 1, Columns.Count).End(xlToLeft).Offset(, 1) = myAry2(k)
Set c = wS.Rows(1).Find(what:=myAry2(k), LookIn:=xlValues, lookat:=xlWhole)
Range(wS.Cells(2, c.Column), wS.Cells(lastRow, c.Column)).SpecialCells(xlCellTypeVisible).Copy
.Cells(myRow + 2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll
Next k
.Cells(Rows.Count, "A").End(xlUp).CurrentRegion.Borders.LineStyle = xlContinuous
Case Else: myAry2 = Array("資格1", "資格2", "資格3", "資格4")
For k = 0 To UBound(myAry2)
.Cells(myRow + 1, Columns.Count).End(xlToLeft).Offset(, 1) = myAry2(k)
Set c = wS.Rows(1).Find(what:=myAry2(k), LookIn:=xlValues, lookat:=xlWhole)
Range(wS.Cells(2, c.Column), wS.Cells(lastRow, c.Column)).SpecialCells(xlCellTypeVisible).Copy
.Cells(myRow + 2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll
Next k
Cells(Rows.Count, "A").End(xlUp).CurrentRegion.Borders.LineStyle = xlContinuous
End Select
End If
Next i
wS.AutoFilterMode = False
.Columns.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

＞隣に抽出ボタンを作ってそれを押すと抽出、さらに隣にクリアボタンを作って
とありますので、
「表示用」シートにコマンドボタンを二つ配置してのコードが必要だと思いますが、
文字制限数を超えそうなので
一旦ここまでで投稿します。m(_ _)m

No.4 回答者： tom04 回答日時： 2015/06/14 22:54

No.3です。

今度は各コマンドボタンのコードを載せてみます。
まず「抽出」用のコードは

Private Sub CommandButton1_Click()
Dim c As Range
If Range("A1") <> "" Then
Set c = Worksheets("元データ").Range("A:A").Find(what:=Range("A1"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Call 抽出
Else
MsgBox "該当データなし"
End If
End If
End Sub

次に「クリア用」のコード

Private Sub CommandButton2_Click()
Dim i As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(i, "A") <> "" Then
If Cells(i, "A") <> "支社名" And InStr(Cells(i, "A"), "関連") = 0 Then
Cells(i, "A").EntireRow.Delete
End If
End If
Next i
Application.ScreenUpdating = True
End Sub

※　「元データ」シートは1行目が項目行でデータは2行目以降にあるとしています。

※　コード内に項目名を入れていますので、
コードに記載している「項目」が「元データ」シートにあるというのが大前提です。

一発で解決！とはいかないと思いますが
まずはこの程度で・・・m(_ _)m