A列を検索し一致した行を表示。さらにそれらの平均を出す。

質問

こんばんは、いつもお世話になっています。

今回は関数で出来るのかわからないんですが質問させてください。

　　　Ａ　　　Ｂ　　　Ｃ　　
　　商品名　　個数　販売数
１　りんご　　１　　　２
２　なし　　　３　　　５
３　ぶどう　　７　　　９
４　りんご　　２　　　４

上のようにSheet1に表があったとします。
Ａ列の「りんご」を検索し、１行目と４行目を別シートに表示
その結果を下のように平均・最大・最小という風に表示したいのですが可能でしょうか?

　　　Ａ　　　Ｂ　　　Ｃ　　
　　商品名　　個数　販売数
１　りんご　　１　　　２
２　りんご　　２　　　４
３　
４　最大　　　２
５　最小　　　１
６　平均　　　２

実際はに作っている表の列は「Ｚ」まであり、行も毎日入力するものなのでかなりの数になります。
自分でもいろいろ試してＡ列を=DGETで検索したのですが１つしか表示されなくてダメでした。

だめだめな自分にお知恵を貸してくださいm(_ _)m

回答No.26

ka_na_de

私もVBA勉強中です。

趣味でやっているだけなので気楽に
少しずつ覚えようと思っています。

私が良く参考にしているホームページを紹介します。

エクセルのヘルプがもっと使いやすかったら
ヘルプだけでいいんですけどね～。

モーグ
http://www.moug.net/index.htm

よねさんのWordとExcelの小部屋～Excel(エクセル)VBA入門
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/index.html

Excel VBA 入門講座
http://excelvba.pc-users.net/

Let's Excel VBA
http://www.sanynet.ne.jp/~awa/excelvba/kouza.html

MilkHouse
http://www6.plala.or.jp/MilkHouse/index.html

Office TANAKA
http://officetanaka.net/excel/index.htm

Excelでお仕事
http://www.asahi-net.or.jp/~ef2o-inue/top01.html

Shun's Page ～Excel VBA Parts Collection
http://t_shun.at.infoseek.co.jp/My_Page/Excel-VBA/vba_menu.htm

Excel講座
http://www.serpress.co.jp/excel/

ExcelVBAへの道
http://www.voicechatjapan.com/excelvba/index.html

インストラクターのネタ帳
http://www.relief.jp/itnote/archives/cat_62.php

ＥＸＣＥＬノート
http://park11.wakwak.com/~miko/Excel_Note/frame1.htm

Ｖisual　Basic 中学校
http://homepage1.nifty.com/rucio/main/main.htm

だるまのつぶやき～エクセルVBA小技集
http://hp.vector.co.jp/authors/VA033788/kowaza.html

回答No.25

ka_na_de

ka_na_deです。

その他の気になる点も改良しましたので、
アップしておきます。

１点目：ダミーの空白列が丸出しにならないように
　　　　画面の更新を抑制
２点目：元データのシート名をSheet1でなくても
　　　　何でもOKとするように変更
３点目：抽出データと検索リストのシートも、自動で
　　　　作成し、事前に空白シートを準備しなくても
　　　　大丈夫なように変更
４点目：その他、細かな修正

'//--------------標準モジュールに記述-----------------------------------------
Public MyKey As String
Sub test9()
On Error GoTo Err
　　Dim St1Rng As Range, St1Rng2 As Range, St2Rng As Range, St2Rng2 As Range
　　Dim St1 As Worksheet, St2 As Worksheet, St3 As Worksheet
　　Dim St1LastRow As Long, St2LastRow As Long, St2LastCol As Long
　　Dim CalcStartCol As Long, c As Long
　　Dim HeadLineNum As Long, KeyColumn As Long
　　Dim KeyColumnA As String, CalcStartColA As String

　 '=========ユーザー変更箇所=====================================（ここから）====
　　HeadLineNum = 3　　　　'見出し行の数 （データ開始行番号-1)
　　KeyColumnA = "B"　　　 '検索列
　　CalcStartColA = "E"　　'計算開始列
　 '=========ユーザー変更箇所=====================================（ここまで）====

　　Set St1 = ActiveSheet '元データのシート
　　　　　　　　　　　　　'（指定不要です。必ず元データを選択して実行してください）

　　KeyColumn = St1.Range(KeyColumnA & "1").Column　　　　'検索列の列番号取得
　　CalcStartCol = St1.Range(CalcStartColA & "1").Column　'計算開始列の列番号取得

　　Application.ScreenUpdating = False　 '画面の更新を抑止

　　Sheet_Add ("検索リスト")　　　　　'検索リストのシートを追加作成
　　Sheet_Add ("抽出シート")　　　　　'抽出シートを追加作成
　　Set St2 = Worksheets("抽出シート")
　　Set St3 = Worksheets("検索リスト")
　　St1.Move Before:=St2

　　'ダミーの見出し行の挿入　（元の見出し行が結合されている場合への対応）
　　St1.Rows(HeadLineNum + 1).Insert Shift:=xlDown

　　'検索リストの作成
　　St3.Cells.Clear
　　With St1
　　　St1LastRow = .Cells(.Rows.Count, KeyColumn).End(xlUp).Row
　　　.Range(.Cells(HeadLineNum + 1, KeyColumn), .Cells(St1LastRow, KeyColumn)).Copy _
　　　　　 Destination:=St3.Range("A1")
　　End With
　　With St3
　　　.Range("A1").Value = "リスト"
　　　.Columns("A:A").AdvancedFilter _
　　　　　　　Action:=xlFilterCopy, CopyToRange:=.Columns("B:B"), Unique:=True
　　End With

　　'見出し行＋ダミー見出し行＋データ領域
　　Set St1Rng = St1.UsedRange
　　'ダミー見出し行＋データ領域　（オートフィルター領域）
　　Set St1Rng2 = St1Rng.Resize(St1Rng.Rows.Count - HeadLineNum).Offset(HeadLineNum)

　　'オートフィルターによる抽出
　　With St1Rng2
　　　'フィルタ設定
　　　.AutoFilter
　　　If Not St1.AutoFilterMode Then .AutoFilter
　　　'検索ワードの要求
　　　UserForm1.Show
　　　'キャンセル時の処理
　　　If MyKey = "False" Or MyKey = "" Then
　　　　St1.Rows(HeadLineNum + 1).Delete　　'ダミーの見出し行の削除
　　　　Exit Sub '終了
　　　End If
　　　'左端に空白列が存在するばあいへの事前対応
　　　KeyColumn = KeyColumn - .Cells(1).Column + 1
　　　'KeyColumn列を変数MyKeyでデータ抽出
　　　.AutoFilter Field:=KeyColumn, Criteria1:=MyKey
　　　'抽出シートの初期化
　　　St2.Cells.Clear
　　　'抽出データ（可視セル）をコピー&ペースト
　　　.SpecialCells(xlCellTypeVisible).Copy _
　　　　Destination:=St2.Cells(HeadLineNum, .Cells(1).Column)
　　　'フィルタ解除
　　　.AutoFilter
　　End With
　　'見出し行のコピー&ペースト
　　St1.Rows("1:" & HeadLineNum).Copy Destination:=St2.Range("A1")
　　'ダミーの見出し行の削除
　　St1.Rows(HeadLineNum + 1).Delete

　　'最大、最小、平均の計算
　　With St2
　　　St2LastRow = .UsedRange.Cells(.UsedRange.Cells.Count).Row　　'最終行
　　　St2LastCol = .UsedRange.Cells(.UsedRange.Cells.Count).Column '最終列
　　　If St2LastRow - HeadLineNum <= 0 Then Exit Sub
　　　'基準の計算領域
　　　Set St2Rng = _
　　　　　　.Cells(1, CalcStartCol).Resize(St2LastRow - HeadLineNum).Offset(HeadLineNum)
　　　.Cells(St2LastRow + 2, "A").Value = "最大"
　　　.Cells(St2LastRow + 3, "A").Value = "最小"
　　　.Cells(St2LastRow + 4, "A").Value = "平均"
　　　For c = CalcStartCol To St2LastCol
　　　　Set St2Rng2 = St2Rng.Offset(, c - CalcStartCol)
　　　　If WorksheetFunction.Count(St2Rng2) > 0 Then
　　　　　.Cells(St2LastRow + 2, c).Value = WorksheetFunction.Max(St2Rng2)　'最大
　　　　　.Cells(St2LastRow + 3, c).Value = WorksheetFunction.Min(St2Rng2)　'最小
　　　　　.Cells(St2LastRow + 4, c).Value = WorksheetFunction.Average(St2Rng2)　'平均
　　　　End If
　　　Next c
　　　.Activate
'　　　.Cells.Columns.AutoFit　'列幅の自動調整（必要に応じて有効にして下さい）
　　　.Range("A1").Select
　　End With

　　Application.ScreenUpdating = True　'画面の更新を許可

　　'変数の解放
　　Set St1 = Nothing: Set St2 = Nothing:　 Set St3 = Nothing
　　Set St1Rng = Nothing:　Set St1Rng2 = Nothing
　　Set St2Rng = Nothing:　Set St2Rng2 = Nothing
　　Exit Sub
Err:
　Application.ScreenUpdating = True
　MsgBox "error"
End Sub

Sub Sheet_Add(StName As String)
　Dim Scheck As Boolean
　Dim St As Worksheet
　Scheck = False
　For Each St In Worksheets
　　If St.Name = StName Then
　　　Scheck = True
　　　Exit For
　　End If
　Next
　If Scheck = False Then
　　Sheets.Add.Name = StName
　End If
End Sub

'//--------------ユーザーフォームモジュールに記述-----------------
Private Sub UserForm_Initialize()
　'ユーザーフォームの初期設定
　Dim St3LastRow As Long

　With Worksheets("検索リスト")
　　 St3LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row '最終行
　End With

　With UserForm1
　　.Caption = "リストから選択してください"
　　.CommandButton1.Caption = "OK"
　　.CommandButton2.Caption = "CANCEL"
　　With .ComboBox1
　　　.Style = fmStyleDropDownCombo
　　　.RowSource = "検索リスト!B2:B" & St3LastRow
　　　.ListIndex = -1
　　End With
　End With
End Sub

Private Sub CommandButton1_Click()
　'OKボタンが押された場合
　MyKey = UserForm1.ComboBox1.Value
　Unload Me
End Sub

Private Sub CommandButton2_Click()
　'キャンセルボタンが押された場合
　MyKey = "False"
　Unload Me
End Sub

'----------シートモジュールに記述-----------------------
Private Sub CommandButton1_Click()
　Call test9
End Sub

補足

こんばんは、ka_na_deさん。

現在、早速職場のシートに導入し活用させていただいております。
今まで、検索しsubtotal等を用いて計算してたのが、ボタン一つで出来るようになり業務も効率化できました。

自分でも出来るようになればといいのですが・・・現在、本を購入し勉強しているところです。

今回は本当にありがとうございました。。

回答No.24

ka_na_de

ka_ne_deです。

早速、改良しました。

１点目：　すべて文字列の列は計算しないように修正
２点目：　ユーザーフォームでキャンセルボタンを押した場合に
　　　　　ダミーの見出し列が残る不具合を修正
３点目：　ユーザーフォームで何も入力せずに「OK」を押した場合
　　　　　にもキャンセルと同じ処理を行うように修正
４点目：　計算開始列を　"E" のように指定しやすく変更
　　　　　同様に、検索列も　"B"のように指定しやすく変更
　　　　　（前回の説明箇所が変わりました。）

尚、１点目の改良で、データ以外のところで塗りつぶしなどがあると
エラーになるかもという心配も同時に解消されました。

Public MyKey As String
Sub test8()
On Error GoTo Err
　　Dim St1Rng As Range, St1Rng2 As Range, St2Rng As Range, St2Rng2 As Range
　　Dim St1 As Worksheet, St2 As Worksheet, St3 As Worksheet
　　Dim St1LastRow As Long, St2LastRow As Long, St2LastCol As Long
　　Dim HeadLineNum As Long, KeyColumn As Long
　　Dim CalcStartCol As Long, c As Long
　　Dim KeyColumnS As String, CalcStartColS As String

　　Set St1 = Worksheets("Sheet1") '元データのシート
　　Set St2 = Worksheets("Sheet2") '抽出するシート
　　Set St3 = Worksheets("Sheet3") '検索ワードリストのシート

　　HeadLineNum = 3　　　　'見出し行の数 （データ開始行番号-1)
　　KeyColumnS = "B"　　　 '検索列
　　CalcStartColS = "E"　　'計算開始列

　　KeyColumn = St1.Range(KeyColumnS & "1").Column　　 '検索列の列番号取得
　　CalcStartCol = St1.Range(CalcStartColS & "1").Column　'計算開始列の列番号取得

　　'ダミーの見出し行の挿入
　　St1.Rows(HeadLineNum + 1 & ":" & HeadLineNum + 1).Insert Shift:=xlDown

　　Set St1Rng = St1.UsedRange
　　'データ領域＋ダミー見出し行
　　Set St1Rng2 = St1Rng.Resize(St1Rng.Rows.Count - HeadLineNum).Offset(HeadLineNum)

　　'検索ワードリストの作成
　　St3.Cells.Clear
　　With St1
　　　St1LastRow = .Cells(.Rows.Count, KeyColumn).End(xlUp).Row
　　　.Range(.Cells(HeadLineNum + 1, KeyColumn), .Cells(St1LastRow, KeyColumn)).Copy _
　　　　　 Destination:=St3.Range("A1")
　　End With
　　With St3
　　　.Range("A1").Value = "リスト"
　　　.Columns("A:A").AdvancedFilter _
　　　　　　　Action:=xlFilterCopy, CopyToRange:=.Columns("B:B"), Unique:=True
　　End With

　　'オートフィルターによる抽出
　　With St1Rng2
　　　'フィルタ設定
　　　.AutoFilter
　　　'検索ワードの要求
　　　UserForm1.Show
　　　'キャンセル時の処理
　　　If MyKey = "False" Or MyKey = "" Then
　　　　St1.Rows(HeadLineNum + 1).Delete　　'ダミーの見出し行の削除
　　　　Exit Sub '終了
　　　End If
　　　'左端の空白列の補正
　　　KeyColumn = KeyColumn - .Cells(1).Column + 1
　　　'変数MyKeyでデータ抽出
　　　.AutoFilter Field:=KeyColumn, Criteria1:=MyKey
　　　'抽出シートの初期化
　　　St2.Cells.Clear
　　　'抽出データ（可視セル）をコピー&ペースト
　　　.SpecialCells(xlCellTypeVisible).Copy _
　　　　Destination:=St2.Cells(HeadLineNum, .Cells(1).Column)
　　　'フィルタ解除
　　　.AutoFilter
　　　'見出し行のコピー&ペースト
　　　St1.Rows("1:" & HeadLineNum).Copy _
　　　　　　 Destination:=St2.Range("A1")
　　End With
　　'ダミーの見出し行の削除
　　St1.Rows(HeadLineNum + 1).Delete

　　'最大、最小、平均の計算
　　With St2
　　　St2LastRow = .UsedRange.Cells(.UsedRange.Cells.Count).Row　　'最終行
　　　St2LastCol = .UsedRange.Cells(.UsedRange.Cells.Count).Column '最終列
　　　If St2LastRow - HeadLineNum <= 0 Then Exit Sub
　　　'基準の計算領域
　　　Set St2Rng = _
　　　　　　.Cells(1, CalcStartCol).Resize(St2LastRow - HeadLineNum).Offset(HeadLineNum)
　　　.Range("A" & St2LastRow + 2).Value = "最大"
　　　.Range("A" & St2LastRow + 3).Value = "最小"
　　　.Range("A" & St2LastRow + 4).Value = "平均"
　　　For c = CalcStartCol To St2LastCol
　　　　Set St2Rng2 = St2Rng.Offset(, c - CalcStartCol)
　　　　If WorksheetFunction.Count(St2Rng2) > 0 Then
　　　　　.Cells(St2LastRow + 2, c).Value = WorksheetFunction.Max(St2Rng2)　'最大
　　　　　.Cells(St2LastRow + 3, c).Value = WorksheetFunction.Min(St2Rng2)　'最小
　　　　　.Cells(St2LastRow + 4, c).Value = WorksheetFunction.Average(St2Rng2)　'平均
　　　　End If
　　　Next c
　　　.Activate
　　End With

　　'変数の解放
　　Set St1 = Nothing
　　Set St2 = Nothing
　　Set St3 = Nothing
　　Set St1Rng = Nothing
　　Set St1Rng2 = Nothing
　　Set St2Rng = Nothing
　　Set St2Rng2 = Nothing
　　Exit Sub
Err:
　MsgBox "error"
End Sub

回答No.23

ka_na_de

ka_ne_deです。

質問の件ですが、
まず、計算領域はコードの下から20行目あたりに
For c = CalcStartCol To St2LastCol
とありますよね、
ここで、CalcStartCol　から　St2LastCol　まで
繰り返し計算させています。

CalcStartColは、計算（calculation)を開始（Start）する列（Column)
という意味で名づけた変数です。
コードの最初の方に、
CalcStartCol = St1.Range("E1").Column　'集計開始列の列番号取得
となっていると思いますが、ここで、計算開始列を指定しています。
E列であれば、CalcStartCol = 5とすれば済むのですが、
AE列とかになると、指折り数えるのが大変でしょ。
なので、St1.Range("E1").Column　のように
自動で列番号を取得させています。
E1をAE1に変えれば、
VBAが勝手にAE列の列番号、すなわち、31を計算してくれます。

次に、
St2LastCol　は、シート２(St2)の最終（Last）の列(Column）
という意味で名づけた変数です。
最後のほうに
St2LastCol = .UsedRange.Cells(.UsedRange.Cells.Count).Column '最終列
という行があると思います。
ここで、Sheet2で使用している領域の最終列の番号を自動で取得しています。
もちろん、直接　St2LastCol =　10　とか指定してもいいんですが、
これだと、データが横方向に増えたときに、その都度コードを修正
しないといけませんね。それを避けるために自動で計算させています。

＜結論＞
いろいろ書きましたが、結論としては、
現状は　「E列」～「データがある列」まで　計算されます。
これを
例えば、「Z列」からとしたければ、
CalcStartCol = St1.Range("E1").Column　'集計開始列の列番号取得
　　　　　　↓
CalcStartCol = St1.Range("Z1").Column　'集計開始列の列番号取得

とするだけです。

余談ですが、
もし、E列以降で計算をしたいが、
H列とK列には文字列が入っているので、
これらの列は除外して計算したい。
といった事もありますよね。
さあ、どうしましょう。

やはり、自動で判定してエラーを出さないように
すべきでしょうね。

これは、明日以降の課題にしておきますので、
しばらくお待ちください。

回答No.22

ka_na_de

ka_na_deです。

うまくいったようですね。

良かった良かった。私も素直に嬉しいです。

まだ、気になる箇所がありますが、この辺で一旦終了ですね。

例えば、フィルター領域をUsedRangeを基準に設定してしまった事で、
データのない場所に塗りつぶしなどの書式のみが設定されていると、
そこまで計算対象となるので、Averageの計算でエラーが出るだろう
な～　とか。

Sheet2,Sheet3は自動で生成するようにすべきだったかな～　

ダミーの見出し行が丸出しだな～とか・・・

あと、ユーザーフォームには、何の入力案内もしていませんので、
ご自分で改良してみてください。
マクロの実行ボタンも自分で名前をつけてください。

気になる所を挙げれば切りが無いので、これで終わります。
お疲れ様でした。

尚、追加で質問や改良の要望があればコメントください。
分かる範囲で回答します。

補足

ka_na_deさん、こんばんは。
大変良いものを作って頂きありがとうございました。

今日早速職場へ持って行きシートに導入したところ、業務効率化が図れてとても重宝致して、再び感謝感謝でした♪

で、色んなシートにも導入しようかと考えていますが、早速難題にぶつかりまして、お言葉に甘えて再び質問させてください。
作って頂いたtest7の計算領域はＥ列～Ｖ列でしたが、これをＶ列以降（Ｚ列など）にするには、どこを弄ればいいのでしょうか？

質問ばかりで、すみません。

回答No.21

ka_na_de

最終版として、まとめます。
シート名、マクロ名などは、変更してもらって結構です。

＜前提＞
　元データ：Sheet1のA1～
　　　　　　３行見出し、４行目よりデータ
　　　　　　B列に検索ワードあり
　　　　　　E列～V列まで数値データあり
　抽出データ：Sheet2のA1～
　　　　　　　抽出データの１行下から、集計計算
　　　　　　　A列：最大、最小、平均の見出し
　　　　　　　E列以降：計算結果
　検索ワード：Sheet3のB2以下に表示されます。

＜設定方法＞
最初にユーザーフォームを作ります。
１）VBエディターの左上にプロジェクトエクスプローラーが
　　表示されていると思いますので、VBAProjectの文字の上で
　　右クリックし、「挿入」→「ユーザーフォーム」としてください
２）「ツールボックス」が表示されますので、その中から、
　　「コンボボックス」を選択し、ユーザーフォームにドラッグ。
　　適当に大きさを調整してください。
３）次に、コマンドボタンを選択し、ドラッグ
　　もう一回、コマンドボタンを選択し、ドラッグ
４）最初のコマンドボタンに名前をつけます。
　　コマンドボタンの上で右クリックし、プロパティーを選択
　　左下にずらっと設定項目が並んでいると思いますので、
　　その中の「Caption」の右側に「OK」と入力
５）２個目のコマンドボタンには、同様に「CANCEL」と名前を
　　つけてください。　フォーム上も変化しているはずです。
　　注）２つのコマンドボタンは作成した順に
　　CommandButton1、CommandButton2というオブジェクト名が
　　ついていますので、前者のCaptionを「OK」にして下さい。
６）左上のプロジェクトエクスプローラーに
　　「UserForm１」というモジュールができていますので、
　　ダブルクリック。そして、右側に　以下のコードを
　　貼り付けてください。

Private Sub CommandButton1_Click()
　'OKボタンが押された場合
　MyKey = UserForm1.ComboBox1.Value
　Unload Me
End Sub

Private Sub CommandButton2_Click()
　'キャンセルボタンが押された場合
　MyKey = "False"
　Unload Me
End Sub

Private Sub UserForm_Initialize()
　'ユーザーフォームの初期設定
　Dim St3LastRow As Long

　With Worksheets("Sheet3")
　　 St3LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
　End With
　UserForm1.ComboBox1.Style = fmStyleDropDownCombo
　UserForm1.ComboBox1.RowSource = "Sheet3!B2:B" & St3LastRow
　UserForm1.ComboBox1.ListIndex = -1
End Sub

次に、以下のメインコードを標準モジュールに貼り付けます。
１）VBエディターの左上にプロジェクトエクスプローラーが
　　表示されていると思いますので、VBAProjectの文字の上で
　　右クリックし、「挿入」→「標準モジュール」としてください
２）右の欄に以下のコードを貼り付けます。
　　注意）MyKeyをパブリック変数としたため、SUBの外に出てます。

Public MyKey As String
Sub test7()
On Error GoTo Err
　　Dim St1Rng As Range, St1Rng2 As Range, St2Rng As Range
　　Dim St1 As Worksheet, St2 As Worksheet, St3 As Worksheet
　　Dim St1LastRow As Long, St2LastRow As Long, St2LastCol As Long
　　Dim HeadLineNum As Long, KeyColumn As Long
　　Dim CalcStartCol As Long
　　Dim c As Long

　　Set St1 = Worksheets("Sheet1") '元データのシート
　　Set St2 = Worksheets("Sheet2") '抽出するシート
　　Set St3 = Worksheets("Sheet3") '検索ワードリストのシート

　　HeadLineNum = 3　 '見出し行の数 （データ開始行番号-1)
　　KeyColumn = St1.Range("B1").Column　　 '検索列の列番号取得
　　CalcStartCol = St1.Range("E1").Column　'集計開始列の列番号取得

　　'ダミーの見出し行の挿入
　　St1.Rows(HeadLineNum + 1 & ":" & HeadLineNum + 1).Insert Shift:=xlDown

　　Set St1Rng = St1.UsedRange
　　'データ領域＋ダミー見出し行
　　Set St1Rng2 = St1Rng.Resize(St1Rng.Rows.Count - HeadLineNum).Offset(HeadLineNum)

　　'検索ワードリストの作成
　　St3.Cells.Clear
　　With St1
　　　St1LastRow = .Cells(.Rows.Count, KeyColumn).End(xlUp).Row
　　　.Range(.Cells(HeadLineNum + 1, KeyColumn), .Cells(St1LastRow, KeyColumn)).Copy _
　　　　　 Destination:=St3.Range("A1")
　　End With
　　With St3
　　　.Range("A1").Value = "リスト"
　　　.Columns("A:A").AdvancedFilter _
　　　　　　　Action:=xlFilterCopy, CopyToRange:=.Columns("B:B"), Unique:=True
　　End With

　　'オートフィルターによる抽出
　　With St1Rng2
　　　'フィルタ設定
　　　.AutoFilter
　　　'検索ワードの要求
　　　UserForm1.Show
　　　If MyKey = "False" Then Exit Sub
　　　'左端の空白列の補正
　　　KeyColumn = KeyColumn - .Cells(1).Column + 1
　　　'変数MyKeyでデータ抽出
　　　.AutoFilter Field:=KeyColumn, Criteria1:=MyKey
　　　'抽出シートの初期化
　　　St2.Cells.Clear
　　　'抽出データ（可視セル）をコピー&ペースト
　　　.SpecialCells(xlCellTypeVisible).Copy _
　　　　Destination:=St2.Cells(HeadLineNum, .Cells(1).Column)
　　　'フィルタ解除
　　　.AutoFilter
　　　'見出し行のコピー&ペースト
　　　St1.Rows("1:" & HeadLineNum).Copy _
　　　　　　 Destination:=St2.Range("A1")
　　End With
　　'ダミーの見出し行の削除
　　St1.Rows(HeadLineNum + 1).Delete

　　'最大、最小、平均の計算
　　With St2
　　　St2LastRow = .UsedRange.Cells(.UsedRange.Cells.Count).Row　　'最終行
　　　St2LastCol = .UsedRange.Cells(.UsedRange.Cells.Count).Column '最終列
　　　If St2LastRow - HeadLineNum <= 0 Then Exit Sub
　　　'基準の計算領域
　　　Set St2Rng = _
　　　　　　.Cells(1, CalcStartCol).Resize(St2LastRow - HeadLineNum).Offset(HeadLineNum)
　　　.Range("A" & St2LastRow + 2).Value = "最大"
　　　.Range("A" & St2LastRow + 3).Value = "最小"
　　　.Range("A" & St2LastRow + 4).Value = "平均"
　　　For c = CalcStartCol To St2LastCol
　　　　.Cells(St2LastRow + 2, c).Value = _
　　　　　　　　　WorksheetFunction.Max(St2Rng.Offset(, c - CalcStartCol))　'最大
　　　　.Cells(St2LastRow + 3, c).Value = _
　　　　　　　　　WorksheetFunction.Min(St2Rng.Offset(, c - CalcStartCol))　'最小
　　　　.Cells(St2LastRow + 4, c).Value = _
　　　　　　　　　WorksheetFunction.Average(St2Rng.Offset(, c - CalcStartCol))　'平均
　　　Next c
　　　.Activate
　　End With

　　'変数の解放
　　Set St1 = Nothing
　　Set St2 = Nothing
　　Set St3 = Nothing
　　Set St1Rng = Nothing
　　Set St1Rng2 = Nothing
　　Set St2Rng = Nothing

　　Exit Sub
Err:
　MsgBox "error"
End Sub

最後におまけですが、このtest7の実行は、
シート上にコマンドボタンを貼り付けて、
それがクリックされたら実行するようにすると
さらに便利です。

例えば、Sheet1を選択し、
上部メニューで
「表示」→「ツールバー」→「コントロールツールボックス」
として、「コントロールツールボックス」を表示させます。
「コマンドボタン」を押して選択し
シート上で、ドラッグしてボタンを配置
ボタンをダブルクリック
（もし、ダブルクリックできないなら、
　デザインモードになっていないので
　「コントロールツールボックス」の三角定規アイコン
　を押してデザインモードにしてください。）

Private Sub CommandButton1_Click()

End Sub

とでてくるので、
Call test7
を中にコピーしてください。
そして、Sheet1に戻り、三角定規ボタンを押して、
デザインモードを終了。
その後、ボタンを押せばマクロが実行されます。

以上です。

お礼

できました。
本当に深く深く感謝・感激しています。
ありがとうございました。

自分もこれから勉強し作っていただいたのを基本にして、所々変更していきたいと思います。
あと、他のファイルにも使えそうなので、移植したいと考えています。

本当にありがとうございました。

回答No.20

ka_na_de

まず、シートにボタンを貼り付けていますか？

上部メニューで
「表示」→「ツールバー」→「コントロールツールボックス」
として、
「コントロールツールボックス」を表示させます。

「コマンドボタン」を押して選択し
シート上で、ドラッグしてボタンを配置

ボタンをダブルクリック
（もし、ダブルクリックできないなら、
　デザインモードになっていないので
　「コントロールツールボックス」の三角定規アイコン
　を押してデザインモードにしてください。）

Private Sub CommandButton1_Click()

End Sub

とでてくるので、
Call test6
を中にコピーしてください。

そして、三角定規ボタンを押して、
デザインモードを終了。

その後、ボタンを押せばマクロが実行されます。

それから、現在、コンボボックスに表示されるリストは
B2:B100
となっています。
本来はリストの数だけ表示するべきなので後に変更します。

エラーがすべて無くなり思いどおりの動きをするように
なったら教えて下さい。

補足

一応、ボタンも配置し動作も良好になったと思います。
その後の、抽出から平均算出までエラーも出ずなりました。
ありがとうございます。

回答No.19

ka_na_de

ka_na_deです。

私はずっとシート２から実行していたので、
この問題に気づきませんでした。

先ほどの箇所を
以下に変更してください。

　　　Next c
　　　.Activate
　　End With

それから、ボタンを押してマクロ実行はできてますか？

補足

＞＞ボタンを押してマクロ実行はできてますか？
先ほどから、やっているのですがtest6が実行されません。

コードは先ほど書かれていたコードのみでいいのですか？

Private Sub CommandButton1_Click()
Call test6
End Sub

回答No.18

ka_na_de

エラー再現できました。

ちょっと待っててください。

回答No.17

ka_na_de

もう少しですね。

意味不明なエラーですね。

試しに、
' .Range("A1").Select
のように、先頭に　'　
を入れてコメント化してください（緑色になります）
これでエラーになる場合は、どこが黄色になりますか？

くどいようですが、
Sheet１に空白行が残っていたら削除しておいて下さい。