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

質問

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

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

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

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

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

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

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

回答No.16

ka_na_de

ka_na_deです。

Public MyKey As String
Sub test6()
・
・
End Sub

は、どこに記述していますか？

標準モジュールに記述しないといけませんが、
ひょっとして
Sheet1やSheet2のシートモジュールに
記述していませんか？

補足

その通りでした。
全くの初心者ですみません。

標準モジュールに打つとメッセージボックスにコンボボックスで選んだ語句が表示されました。

しかし、新たなエラーが表示されました。

実行時エラー　1004
RangeクラスのSelectメソッドが失敗しました。

で、デバックを押すと
Next c
.Range("A1").Select
End With

.Range("A1").Select
↑この部分が黄色で塗りつぶしてあります。

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

回答No.15

ka_na_de

ka_na_deです。

＞UserForm1のモジュールの方にあったので、Sub test6() の上部に置いたのですが

UserForm1のモジュールの方にあった宣言文は削除していますか？
Sub test6() の上部と両方に宣言していてもいけません。

どうなってますか？

補足

Sub test6() のみに表示されています。

回答No.14

ka_na_de

ka_na_deです。

やっぱり、MyKeyにリストの文字列が渡されていませんね。

Public MyKey As String
という　宣言文ですが、どこにありますか？

もし、UserForm1のモジュールにあるならダメです。
Sub test6() の上部に置いてください。

それから、Sheet1の３行目以下に空白行が挿入されていたら、
手動で削除しておいて下さい。

あと、エラーとは直接関係ありませんが、
変更したい箇所があるので、
今の問題が解決できたら直します。

まず、上記のMyKeyの宣言場所を調べて教えて下さい。

補足

Public MyKey As String
という　宣言文ですが、どこにありますか？

UserForm1のモジュールの方にあったので、Sub test6() の上部に置いたのですが、まだ1004エラーが出て、メッセージボックスはOKのボタンしか表示されてません。

回答No.13

ka_na_de

ka_na_deです。

＞test6()を実行したのですが、リストはうまく行きました。

Sheet3を見るとリストができているという意味ですか？

ユーザーフォームは表示されますか？
コンボボックスにリストが表示されますか？

もし、ここまでOKだとすると、
MyKey
にリストの値が入っていない可能性があります。

原因１：コマンドボタンのOKとCANCELが逆になっている。
原因２：MyKeyがパブリック変数になっていない。

いずれにしても、MyKeyの値が気になります。

　　'検索ワードの要求
　　　UserForm1.Show
　　　If MyKey = "False" Then Exit Sub

の部分の間に、MsgBox MyKeyを入れて、

　　'検索ワードの要求
　　　UserForm1.Show
　　　MsgBox MyKey
　　　If MyKey = "False" Then Exit Sub

としてみてください。
ユーザーフォームでリストを選択してOKした後、
メッセージボックスが表示され、
MyKey が表示されます。
選択した言葉が表示されているか教えて下さい。

補足

＞＞Sheet3を見るとリストができているという意味ですか？
そうです。Sheet3のA列にSheet1のB列の入力している全てが表示されSheet3のB列にはグループ化されたのが入っています。

＞＞ユーザーフォームは表示されますか？
はい、表示されています。
＞＞コンボボックスにリストが表示されますか？
はい、表示されています。

検索ワードの間にMsgBox MyKeyを入れメッセージボックスを確認したところ、何も表示されなくOKのボタンだけありました。
で、OKを押すと
実行時のエラー1004が表示されました。

回答No.12

ka_na_de

ka_na_deです。

お待たせしました。できました。
説明が長くなりますが、ぜひ試してみてください。

まず、動作の流れとしては、
１）Sheet1の元データのB列をSheet3のA列にコピーして、
　　フィルター操作で重複削除した結果をB列に作成
　　（VBAで自動実行されます）
２）ユーザーフォームを新たに作成しておき（手動）、
　　そこにコンボボックスと二つのコマンドボタンを設置（手動）
　　ユーザーフォームの初期化で、上記Sheet3B列を自動読み込み
３）VBAを実行すると、ユーザーフォームが表示されるので、
　　リストを選択してOKボタンを押すと、選択した内容が
　　パブリック変数のMyKeyに引き渡されます。
　　（MyKey = UserForm1.ComboBox1.Value）
　　CANCELを押すと、"False"を渡す。
４）この値を使って、今までどおり抽出を実行。

となります。

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

Private Sub CommandButton1_Click()
　MyKey = UserForm1.ComboBox1.Value
　Unload Me
End Sub

Private Sub CommandButton2_Click()
　MyKey = "False"
　Unload Me
End Sub

Private Sub UserForm_Initialize()
　UserForm1.ComboBox1.Style = fmStyleDropDownCombo
　UserForm1.ComboBox1.RowSource = "Sheet3!B2:B100"
　UserForm1.ComboBox1.ListIndex = -1
End Sub

次に、以前のメインコードを以下に変更してください。
注意）MyKeyをパブリック変数としたため、SUBの外に出てます。

Public MyKey As String

Sub test6()
'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.ClearContents
　　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.ClearContents
　　　St2.Cells.ClearFormats
　　　'抽出データ（可視セル）をコピー&ペースト
　　　.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
　　　.Range("A1").Select
　　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

最後におまけですが、このtest6の実行は、
シート上にコマンドボタンを貼り付けて、
それがクリックされたら実行するようにすると
さらに便利ですよ。
例えば、Sheet1上にコマンドボタンを設置して
Private Sub CommandButton1_Click()
　Call test6
End Sub
と記述します。
意味がわからなければ、もっと詳しく説明します。
（以下に参考ページを記しました）

以上ですが、なにしろ長いので、うまく行かない時は
コメントしてください。

尚、参考にしたページを紹介します。

１）ユーザーフォームにコンボボックス
http://www.serpress.co.jp/excel/vba019.html

２）シート上のボタンを押してマクロ実行
http://www.moug.net/skillup/ebb/evbb/evbb002-1.htm
　４ページありますが、３ページ目からが設定方法です。

補足

test6()を実行したのですが、リストはうまく行きました。
しかし、何故かSheet2に見出しのみが表示されて結果が全く表示されません。
エラーは発生してません。

度々重なる質問お許しください

回答No.11

ka_na_de

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

＞あと、検索BOXでリストから選ぶのを可能なんでしょうか？
＞例えば、B列に入力されているのを参照し、入力規則のリストみたいな感じでっていうのは可能でしょうか?

できるはずです。
方法１）　どこかのセルに入力規則でB列の検索ワードを入力し、
　　　　　VBAでそのセルの値を取り込む。

方法２）　現在のInputBoxをユーザーフォームに変更して、
　　　　　コンボボックスを使う。

方法１）はすぐにでも可能です。
方法２）は初めてなので時間がかかりますが、基本的な使い方なので
　　　　できるはずです。

しばらくお待ちください。

とりあえず、検索ワード以外を入力したときにエラーにならない
コード（test5）を投稿します。

Sub test5()
'On Error GoTo Err
　　Dim MyKey As String
　　Dim St1Rng As Range, St1Rng2 As Range, St2Rng As Range
　　Dim St1 As Worksheet, St2 As Worksheet
　　Dim 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") '抽出するシート

　　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)

　　With St1Rng2
　　　'フィルタ設定
　　　.AutoFilter
　　　'検索ワードの要求
　　　MyKey = Application.InputBox("検索ワード入力", Type:=2)
　　　If MyKey = "False" Then Exit Sub
　　　'左端の空白列の補正
　　　KeyColumn = KeyColumn - .Cells(1).Column + 1
　　　'変数MyKeyでデータ抽出
　　　.AutoFilter Field:=KeyColumn, Criteria1:=MyKey
　　　'抽出シートの初期化
　　　St2.Cells.ClearContents
　　　St2.Cells.ClearFormats
　　　'抽出データ（可視セル）をコピー&ペースト
　　　.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
　　　.Range("A1").Select
　　End With

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

　　Exit Sub
Err:
　MsgBox "error"
End Sub

回答No.10

ka_na_de

ka_na_deです。

あと一息ですね。

Sheet2の抽出結果を良く眺めてください。
最後のV列あたりまで、きちんとデータが
抽出されていますか？

もし、されていなければ、
averageの計算ができずに（０割り）で
エラーになっているのかも知れません。

なにか、手がかりはありませんか？

それから、VBエディターでコードのどの行で
エラーになっているか、
黄色で表示されている行を教えてください。

補足

あっ、すみません。
V列に文字列で0の値があったので、数値に変更したら、エラーはでなくなりました。

あと、検索BOXでリストから選ぶのを可能なんでしょうか？
例えば、B列に入力されているのを参照し、入力規則のリストみたいな感じでっていうのは可能でしょうか?

回答No.9

ka_na_de

ka_na_deです。

検索語がヒットしなかった場合はエラーになりますね。

ヒットしない場合は、最大、最小などの計算を行わないように改良
しましたので、次回に再投稿します。

補足

１回、実行すると検索BOXが出て検索語を入れ検索し最大・最小・平均値がSheet2に表示されて、エラーが出ます。

あと、VBAは全くの初心者で実行する時は、VBAの画面にして上の「実行」を押し、Sub/ユーザーフォームの実行でプログラムを実行するようになるんですか？
Excelの画面のままで実行する方法はないのでしょうか？

度々の質問お許しください。

回答No.8

ka_na_de

ka_na_deです。

セルが結合されていたんですね。
エラーになりますね。勉強になりました。

修正しましたので、お試しください。

それから、データが入力されている所以外のセルに
罫線や塗りつぶしがあると、
エラーになるかもしれません。

＞このようなことに貴重な時間を割いて頂きありがとうございます。
趣味でやってますので、気にしないで下さいね。
逆に勉強の題材を提供してもらって感謝してるところですよ。

Sub test4()
'On Error GoTo Err
　　Dim MyKey As String
　　Dim St1Rng As Range, St1Rng2 As Range, St2Rng As Range
　　Dim St1 As Worksheet, St2 As Worksheet
　　Dim 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") '抽出するシート

　　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 + 1).Offset(HeadLineNum)

　　With St1Rng2
　　　'フィルタ設定
　　　.AutoFilter
　　　'検索ワードの要求
　　　MyKey = Application.InputBox("検索ワード入力", Type:=2)
　　　If MyKey = "False" Then Exit Sub
　　　'左端の空白列の補正
　　　KeyColumn = KeyColumn - .Cells(1).Column + 1
　　　'変数MyKeyでデータ抽出
　　　.AutoFilter Field:=KeyColumn, Criteria1:=MyKey
　　　'抽出シートの初期化
　　　St2.Cells.ClearContents
　　　St2.Cells.ClearFormats
　　　'抽出データ（可視セル）をコピー&ペースト
　　　.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 '最終列
　　　'基準の計算領域
　　　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
　　　.Range("A1").Select
　　End With

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

　　Exit Sub
Err:
　MsgBox "error"
End Sub

補足

素晴らしい!!
検索結果も最大・最小・平均も完璧に思ってる通りに出てきました。
しかし、その後またエラーが出ました。
さっきのエラーと同じで

実行時エラー　1004
アプリケーション定義またはオブジェクト定義のエラーです。

塗りつぶしてるセルや罫線はありません。

回答No.7

ka_na_de

ka_na_deです。

test3に関して、
A列が空白列であった場合はエラーとなります。

改良しましたので、次回あわせて投稿します。

test3でうまくいった場合は、
締め切らないでコメント下さい。
最終版として投稿します。

補足

おはようございます。
このようなことに貴重な時間を割いて頂きありがとうございます。
TEST3を試してみましたが、エラーがでました。

実行時エラー　1004
アプリケーション定義またはオブジェクト定義のエラーです。

A列には日付が入りますので空白セルはありません。
見出しは結合している所があります。
A列はA1～A3まで結合しています。
D列まで同じように結合しています。

お手数ですが、よろしくお願いします。