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

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

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

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

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

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

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

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

No.1 回答者： 134 回答日時： 2007/08/24 23:22

ひとつの手法として

１．　1行目とA列に挿入をかけて、空けてください。

２．1行目に、2マス使って、左側を「検索データ」と入力する。
３．右側は、データ→入力規則→リスト　により、商品名のリストが、並ぶようにします。（仮に、このセルをＤ１セルとします）ついでなので、何か表示させておいてください。

　　１行目＝空き、２行目＝タイトル（商品名、個数、販売数…）となり、３行目からデータが並ぶことになりますよね。（Ｂ３よりデータが始まると思います）

４．Ａ３セルに以下の数列を入れます。
=if(b3=$d$1,max($b$2:b2)+1,"")
そして、この関数を下までドラッグします。

Ｄ１で指定した商品だけ、ナンバーリングされると思います。

５．Ａ２から、表全体を覆い、なお余分にドラッグし、挿入→名前で名前をつけます。（仮に「一覧表」と名付けます）

６．シート２を選択します。

７．１行目に　最大値、最小値、平均　と入れておきます。
　　３行目に表題を入れます（Ａ３＝商品名、Ｂ３＝個数、Ｃ３＝販売数…）
８．Ａ４セルに以下の関数を入力します。
=IF(ISERROR(VLOOKUP(ROW()-3,一覧表,2,0)),"",VLOOKUP(ROW()-3,一覧表,2,0))

９．Ｂ４セルに以下の関数を入力します。
=IF(ISERROR(VLOOKUP(ROW()-3,一覧表,3,0)),"",VLOOKUP(ROW()-3,一覧表,3,0))

10．Ｃ４セルに以下の関数を入力します。
=IF(ISERROR(VLOOKUP(ROW()-3,一覧表,4,0)),"",VLOOKUP(ROW()-3,一覧表,4,0))

11．Ａ４～Ｃ４セルを選択し、関数を下までコピーします。

　ここで、シート1Ｄ１セルで選択したデータが列挙されると思います。

12．最大値、最小値、平均を通常通り、範囲指定して下さい。

Ｚ列まで使用ということで、最大、最小、平均をどのデータでどのように表示したいのか分かりませんので、このように書きました。


row()により、検索をかけていますので、１～３行目をそれぞれ最大、最小、平均とし、4行目に表題、5行目からデータという場合には、row()-4とすれば対応可能です。

いかがでしょうか？

No.2 回答者： mike_g 回答日時： 2007/08/24 23:46

　　　A　　　B　　　C　　 …

1　 最大　　　 7　　　 9　…
2　 最小　　　 1　　　 2　…
3　 平均　　3.25　　　 5　…
4
5　 商品名　個数　販売数　…
6　 りんご　　 1　　　 2　…
7　 なし　　　 3　　　 5　…
8　 ぶどう　　 7　　　 9　…
9　 りんご　　 2　　　 4　…
10　…　　　　…　　　…　…

B1: =SUBTOTAL(4,B$6:B$1000)
B2: =SUBTOTAL(5,B$6:B$1000)
B3: =SUBTOTAL(1,B$6:B$1000)
範囲 B1:B3 を右方にズズーッと複写

５行目で[オートフィルタ]を設定した後、「商品名」で“りんご”を選択してみてください。

No.3 回答者： ka_na_de 回答日時： 2007/08/25 12:34

試しにVBAで作ってみました。

一例ですが、ご参考までに。
　元データ：Sheet1のA1～
　抽出データ：Sheet2のA1～
としています。　


Sub test()
On Error GoTo Err
　　Dim MyKey As String
　　Dim St1Rng As Range, St2Rng As Range
　　Dim St1 As Worksheet, St2 As Worksheet
　　Dim LastRow As Long, LastCol As Long
　　Dim c As Long
　　　　
　　Set St1 = Worksheets("Sheet1") '元データのシート
　　Set St2 = Worksheets("Sheet2") '抽出するシート
　　Set St1Rng = St1.Range("A1").CurrentRegion 'アクティブセル領域取得
　　
　　St1Rng.AutoFilter　'フィルタ設定

　　'検索ワードの要求
　　MyKey = Application.InputBox("検索ワード入力", Type:=2)
　　If MyKey = "False" Then Exit Sub
　　St1Rng.AutoFilter Field:=1, Criteria1:=MyKey 'MyKeyでデータ抽出
　　
　　St2.Cells.ClearContents
　　
　　'可視セルをコピー&ペースト
　　St1Rng.SpecialCells(xlCellTypeVisible).Copy _
　　　　Destination:=St2.Range("A1")
　　
　　St1Rng.AutoFilter 'フィルタ解除
　　
　　'最大、最小、平均の計算
　　With St2
　　　LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
　　　LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
　　　Set St2Rng = .Range("B2:B" & LastRow)　'基準の計算領域
　　　.Range("A" & LastRow + 2).Value = "最大"
　　　.Range("A" & LastRow + 3).Value = "最小"
　　　.Range("A" & LastRow + 4).Value = "平均"
　　　For c = 2 To LastCol
　　　　.Cells(LastRow + 2, c).Value = _
　　　　　　　　　WorksheetFunction.Max(St2Rng.Offset(, c - 2))
　　　　.Cells(LastRow + 3, c).Value = _
　　　　　　　　　WorksheetFunction.Min(St2Rng.Offset(, c - 2))
　　　　.Cells(LastRow + 4, c).Value = _
　　　　　　　　　WorksheetFunction.Average(St2Rng.Offset(, c - 2))
　　　Next c
　　End With
　　Exit Sub
Err:
　MsgBox "error"
End Sub

この回答への補足

VBAと大層なものを作っていただきありがとうございます。
早速、作っているシートに導入してみたのですが、やはりエラーがでました。

作っているのはA1からV3まで見出しがあり、検索する列はB列です。
色々いじってみたのですが、見出しが表示されず無理でした。

補足日時：2007/08/25 20:01

No.4 回答者： ka_na_de 回答日時： 2007/08/25 21:40

改良しました。

　元データ：Sheet1のA1～
　　　　　　３行見出し、４行目よりデータ
　　　　　　B列に検索ワードあり
　　　　　　C列～V？列まで数値データあり
　　　　　　（検索列の右隣から数値データと仮定してます）

　抽出データ：Sheet2のA1～
　　　　　　　抽出データの１行したから、集計計算
　　　　　　　A列：最大、最小、平均の見出し
　　　　　　　C列以降：計算結果

　データの場所など上記と異なるようであれば修正します。
　尚、検証が十分ではないので、エラーが出る場合は教えて下さい。
　


Sub test2()
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 LastRow As Long, LastCol As Long
　　Dim HeadLineNum As Long
　　Dim KeyColumn As Long
　　Dim c As Long
　　　　
　　Set St1 = Worksheets("Sheet1") '元データのシート
　　Set St2 = Worksheets("Sheet2") '抽出するシート
　　
　　HeadLineNum = 3 '見出し行の数
　　KeyColumn = 2 'B列（2列目）で検索
　　
　　'アクティブセル領域
　　Set St1Rng = St1.Range("A1").CurrentRegion
　　'データ領域＋見出し１行
　　Set St1Rng2 = St1Rng.Resize(St1Rng.Rows.Count - HeadLineNum + 1).Offset(HeadLineNum - 1)
　　
　　St1Rng2.AutoFilter　　　　　'フィルタ設定

　　'検索ワードの要求
　　MyKey = Application.InputBox("検索ワード入力", Type:=2)
　　If MyKey = "False" Then Exit Sub
　　'変数MyKeyでデータ抽出
　　St1Rng2.AutoFilter Field:=KeyColumn, Criteria1:=MyKey 　　
　　St2.Cells.ClearContents
　　
　　'可視セルをコピー&ペースト
　　St1Rng.Resize(HeadLineNum - 1).Copy _
　　　　Destination:=St2.Range("A1")
　　St1Rng2.SpecialCells(xlCellTypeVisible).Copy _
　　　　Destination:=St2.Range("A1").Offset(HeadLineNum - 1)
　　
　　St1Rng2.AutoFilter 'フィルタ解除
　　
　　'最大、最小、平均の計算
　　With St2
　　　LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
　　　LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
　　　Set St2Rng = .Cells(1, KeyColumn + 1).Resize(LastRow - HeadLineNum).Offset(HeadLineNum) '基準の計算領域
　　　.Range("A" & LastRow + 2).Value = "最大"
　　　.Range("A" & LastRow + 3).Value = "最小"
　　　.Range("A" & LastRow + 4).Value = "平均"
　　　For c = KeyColumn + 1 To LastCol
　　　　.Cells(LastRow + 2, c).Value = _
　　　　　　　　　WorksheetFunction.Max(St2Rng.Offset(, c - KeyColumn - 1))
　　　　.Cells(LastRow + 3, c).Value = _
　　　　　　　　　WorksheetFunction.Min(St2Rng.Offset(, c - KeyColumn - 1))
　　　　.Cells(LastRow + 4, c).Value = _
　　　　　　　　　WorksheetFunction.Average(St2Rng.Offset(, c - KeyColumn - 1))
　　　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

この回答への補足

何度もすみません。
エラーがでました。

Sheet2の見出しが4行で表示されてます。
1,2行目はSheet1と同じ1,2行目のセルなのですが、3行目に空白のセルが入り4行目にSheet1と同じ4行目のセルが入っています。

Sheet1のデータはE列からでV列まであります。
そのE列～V列まで全て、最大・最小・平均を出したいのです。

お手数ですが、時間がある時で構わないので宜しくお願いします。

補足日時：2007/08/25 23:08

No.5 回答者： kosamon 回答日時： 2007/08/25 23:12

こんばんば。

まだ解決していないようなので・・・。

平均値なら
=AVERAGE(IF($A$2:$A$5="りんご",B$2:B$5,""))

と入力して＜SHIFT＞＋＜CTRL＞＋＜ENTER＞
でどうでしょう？


参照範囲はあえて絶対参照としています。
私ならこの式一つを入力した後下方向へフィル。
最大ならMAX、最小ならMINと書き換えます。
もちろん、このときも上記のキー操作で確定させます。

詳しくは下記URLを参照ください。

老婆心ながら・・・。
私もマクロ派なのでマクロは否定しませんが、質問者様の場合は
他の回答者様も書いておられるように「関数」を使用した方が
良いと思います。

参考URL：http://pc.nikkeibp.co.jp/pc21/special/hr/hr4.shtml

No.6 回答者： ka_na_de 回答日時： 2007/08/26 08:00

ka_na_deです。

おはようございます。

やはり、データが違うので予期せぬエラーがでますね。
改良しましたので、試して見てください。
見出しに空白行がある場合も考慮しました。

それと、エラー発生時はSUBプロシージャを抜けないように、
On Error Goto をコメントアウトしましたので、
エラー時はVBエディターに戻ります。
エラー時は、どこで止まってしまうか教えてください。

それから、Average関数は空白や文字列は自動的に無視して
計算してくれますので、そのまま使えると思います。

最後に、集計はE列から行うようにしました。（変数にしてます）


Sub test3()
'On Error GoTo Err
　　Dim MyKey As String
　　Dim St1Rng As Range, St2Rng As Range
　　Dim St1 As Worksheet, St2 As Worksheet
　　Dim LastRow As Long, LastCol 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　 '見出し行の数
　　KeyColumn = 2　　 '検索列の番号
　　CalcStartCol = St2.Range("E1").Column　'集計開始列
　
　　'フィルター領域セット
　　Set St1Rng = St1.UsedRange
　
　　'フィルタ設定
　　St1Rng.AutoFilter

　　'検索ワードの要求
　　MyKey = Application.InputBox("検索ワード入力", Type:=2)
　　If MyKey = "False" Then Exit Sub
　　
　　'変数MyKeyでデータ抽出
　　St1Rng.AutoFilter Field:=KeyColumn, Criteria1:=MyKey
　　St2.Cells.ClearContents
　
　　'可視セルをコピー&ペースト
　　St1Rng.SpecialCells(xlCellTypeVisible).Copy _
　　　　Destination:=St2.Range("A1").Offset(HeadLineNum - 1)
　　　　
　　'フィルタ解除
　　St1Rng.AutoFilter
　　　　
　　'見出し行のコピー&ペースト
　　St1.Rows("1:" & HeadLineNum).Copy _
　　　　Destination:=St2.Range("A1")

　　
　
　　'最大、最小、平均の計算
　　With St2
　　　LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row　　　　　'最終行
　　　LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column　'最終列
　　　'基準の計算領域
　　　Set St2Rng = _
　　　　　　.Cells(1, CalcStartCol).Resize(LastRow - HeadLineNum).Offset(HeadLineNum)
　　　.Range("A" & LastRow + 2).Value = "最大"
　　　.Range("A" & LastRow + 3).Value = "最小"
　　　.Range("A" & LastRow + 4).Value = "平均"
　　　For c = CalcStartCol To LastCol
　　　　.Cells(LastRow + 2, c).Value = _
　　　　　　　　　WorksheetFunction.Max(St2Rng.Offset(, c - CalcStartCol))　'最大
　　　　.Cells(LastRow + 3, c).Value = _
　　　　　　　　　WorksheetFunction.Min(St2Rng.Offset(, c - CalcStartCol))　'最小
　　　　.Cells(LastRow + 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

No.7 回答者： ka_na_de 回答日時： 2007/08/26 08:32

ka_na_deです。

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

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

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

この回答への補足

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

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

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

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

補足日時：2007/08/26 09:37

No.8 回答者： ka_na_de 回答日時： 2007/08/26 10:28

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
アプリケーション定義またはオブジェクト定義のエラーです。

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

補足日時：2007/08/26 10:55

No.9 回答者： ka_na_de 回答日時： 2007/08/26 11:01

ka_na_deです。

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

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

この回答への補足

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

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

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

補足日時：2007/08/26 11:12

No.10 回答者： ka_na_de 回答日時： 2007/08/26 11:16

ka_na_deです。

あと一息ですね。

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

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

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

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

この回答への補足

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

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

補足日時：2007/08/26 11:26