VBAで最大値と2番目の取得方法

質問

Excel上のVBAで資料作成をおこなっているのですが、一部、どうしたら良いのかわかりません。
アドバイスをお願いいたします。
■やりたいこと
　・Excelの一覧表で、行ごとに1番大きい値と2番目に大きい値を取得する。
　・取得する際、項目名（1行目にある値）も併せて取得する。
　・取得数の上限は2件のため、1番目、2番目がそれぞれ複数ある場合、
　　あらかじめ用意してある、優先順位の表にしたがって上位2件を取得する。

■例
　・図のような成績表があった場合、取得結果は以下を想定しています。
　　Aさん→国語：100、英語：90
　　Bさん→数学：100、社会：90
　　Cさん→国語：80、数学：60

　※
　　・Aさん：
　　　・最大値→国語：100
　　　・2番目→英語：90
　　　最大値、2番目ともに、そのまま取得でOK。
　　・Bさん：
　　　・最大値→数学：100
　　　　そのまま取得でOK
　　　・2番目→理科と社会の90
　　　　優先順位で社会が上位にあるため、社会を取得。
　　・Cさん：
　　　・最大値→国語と英語の80
　　　　優先順位で国語が上位にあるため、国語を取得。
　　　・2番目→数学と理科の60
　　　　優先順位で数学が上位にあるため、数学を取得。

よろしくお願いします。

回答No.5

WindFaller · ベストアンサー

こんにちは。

この表を見ていて気がついたことですが、#1さんがご指摘の、
「優先順位を考慮した成績表を別に作った方が良さそうに思えます。」
同感です。あえて、それを、プログラム上で行うとすれば、配列変数(myIndex )の中でしかありません。むろん、Excelなら、ダミーの表を作ってもよいかもしれません。一応、既存のユーザーの表自体を動かしてはいけない、という暗黙のルールには従いましたが…。VBAでは、ややこしくなるようです。
#1さんの回答にように、これは、関数でもできるような気がしますね。私自身は、関数が不得意なので、選択肢はありませんでしたが。

'//
Sub OrderAsRequest()
　Dim Rng As Range
　Dim Rng2 As Range
　Dim myIndex As Variant
　Dim i As Long, j As Long, k As Long
　Dim n As Variant
　Dim mySubject As Variant
　Dim max1 As Long, max2 As Long
　Dim subj1 As String, subj2 As String

　'出力先用
　Dim ws As Worksheet
　Dim m As Long
　Set ws = Worksheets(2)　'#4さんと同等にしました。
　m = 1

　Set Rng = Range("A1:F4") 'テスト成績表
　Set Rng2 = Range("A7:B11") '優先順位
　With Rng
　　Set Rng = .Offset(0, 1).Resize(.Rows.Count, .Columns.Count - 1)
　End With
　ReDim mySubject(Rng2.Rows.Count - 1)
　ReDim myIndex(Rng.Rows.Count - 2, Rng.Columns.Count)
　For i = 1 To Rng2.Rows.Count
　　mySubject(i - 1) = Rng2.Cells(i, 2).Value
　Next i

　'Rng2のフォーマットに従い優先順位に並べ替え

　For i = 2 To Rng.Rows.Count
　　myIndex(i - 2, 0) = Rng.Cells(i, 1).Offset(, -1).Value '人名　　F
　　For j = LBound(mySubject) To UBound(mySubject)
　　　n = Application.Match(mySubject(j), Rng.Rows(1), 0)
　　　myIndex(i - 2, j + 1) = Rng.Cells(i, n).Value
　　Next j
　Next i
　k = 2

　'検索
　For i = LBound(myIndex) To UBound(myIndex)
　　For j = LBound(myIndex, 2) + 1 To UBound(myIndex, 2)
　　　If myIndex(i, j) > max1 Then
　　　　max1 = myIndex(i, j)
　　　　subj1 = mySubject(j - 1)
　　　End If
　　Next j
　　'注意:出力先1
　　With ws
　　　.Cells(m, 1).Value = myIndex(i, 0)
　　　.Cells(m, 2).Value = subj1
　　　.Cells(m, 3).Value = max1
　　End With

　　'二番目を調べる
　　For j = LBound(myIndex, 2) + 1 To UBound(myIndex, 2)
　　　If mySubject(j - 1) <> subj1 Then
　　　　If myIndex(i, j) > max2 Then
　　　　　max2 = myIndex(i, j)
　　　　　subj2 = mySubject(j - 1)
　　　　End If
　　　End If
　　Next j
　　'注意:出力先2
　　With ws
　　　.Cells(m, 4).Value = subj2
　　　.Cells(m, 5).Value = max2
　　End With
　　k = k + 1
　　m = m + 1
　　max1 = 0: max2 = 0: subj1 = "": subj2 = ""
　Next i
End Sub

'//

回答No.6

tom04

No.4です。

前回のコードではエラーになりマクロが止まってしまいます。
最後から5行目の
＞wS.Range(Columns(3), Columns(lastCol)).Delete
を
＞Range(wS.Columns(3), wS.Columns(lastCol)).Delete
に変更してください。

どうも失礼しました。m(_ _)m

お礼

ありがとうございます。できました！
その前にいただいたマクロでも止まることなく動きましたよ！

回答No.4

tom04

こんばんは！

一例です。
Sheet1のデータをSheet2のA・B列に表示するようにしてみました。
元データの1行目は項目で、データはA2セル以降にあるとします。
標準モジュールです。

Sub Sample1()
Dim i As Long, k As Long, lastCol As Long
Dim c As Range, r As Range, myRng As Range, wS As Worksheet, myBst, mySnd, myAry
myAry = Array("国語", "英語", "社会", "数学", "理科") '←優先順位★
Set wS = Worksheets("Sheet2")
wS.Cells.Clear
'▼　Sheet2、C1セル以降に科目を優先順位順に表示（作業用として並び替え）
For k = 0 To UBound(myAry)
wS.Cells(1, k + 3) = myAry(k)
Next k
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
With Worksheets("Sheet1")
'▼　Sheet2のC列以降の科目順に検索し、同じ数値がない場合のみその科目の数値を表示
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
For k = 3 To lastCol
Set c = .Rows(1).Find(what:=wS.Cells(1, k), LookIn:=xlValues, lookat:=xlWhole)
If WorksheetFunction.CountIf(wS.Rows(i), .Cells(i, c.Column)) = 0 Then
wS.Cells(i, k) = .Cells(i, c.Column)
End If
Next k
'▼　Sheet2のC列～最終列を「myRng」に格納
Set myRng = Range(wS.Cells(i, "B"), wS.Cells(i, lastCol))
'▼　myRng範囲の最大値と2番目の値を取得
myBst = WorksheetFunction.Max(myRng)
Set c = wS.Rows(i).Find(what:=myBst, LookIn:=xlValues, lookat:=xlWhole)
'▼　万一すべての科目が同点の場合の処理
If WorksheetFunction.Count(myRng) > 1 Then
mySnd = WorksheetFunction.Large(myRng, 2)
End If
Set r = wS.Rows(i).Find(what:=mySnd, LookIn:=xlValues, lookat:=xlWhole)
'▼　Sheet2のA列にSheet1のA列データを、B列に最大値の科目：点数、2番目の科目：点数　を表示
wS.Cells(i, "A") = .Cells(i, "A")
If Not r Is Nothing Then
wS.Cells(i, "B") = wS.Cells(1, c.Column) & "：" & myBst & "、" & wS.Cells(1, r.Column) & "：" & mySnd
Else
wS.Cells(i, "B") = wS.Cells(1, c.Column) & "：" & myBst
End If
Next i
wS.Range(Columns(3), Columns(lastCol)).Delete
wS.Columns.AutoFit
wS.Range("A2").CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub

※　現実問題としてあるかどうかは判りませんが、
すべての科目が同点の場合は1科目（最優先）しか表示されません。m(_ _)m

回答No.3

weboner

>・Cさん：
>・2番目→数学と理科の60？？

国語と英語の80であれば、数学と理科の60は2番目じゃなくて3番目なんじゃ？

回答No.2

mt2008

ANo.1です。
ごめんなさい、VBAでの解決ですね。
先ほどの回答は忘れて下さい。

回答No.1

mt2008

「何番目に大きい」を取り出す時はLARGE関数を使用します。
また、今回の内容ですと、優先順位を考慮した成績表を別に作った方が良さそうに思えます。
添付の図ではA13:F16を優先順位を考慮した成績表として使っています。

B14に↓を入れてB14:F16にコピーしています。
=B2-MATCH(B$13,$B$7:$B$11,0)/100

次にH2とI2には以下の式を入れます。
H2セル：=INDEX($B$1:$F$1,0,MATCH(LARGE($B14:$F14,1),$B14:$F14,0))
I2セル：=INDEX($B$1:$F$1,0,MATCH(LARGE($B14:$F14,2),$B14:$F14,0))

H2:I2を下2つにもコピーします。

こんな感じで如何でしょう。

お礼

ありがとうございます。できました！
当初VBAの予定でしたが、いただいた内容で作業シートとして
持てればその方が簡単かな。とも思い、ただいま検討中です。

補足

webonerさんからご指摘いただきました。ありがとうございます。
Cさんについては、ご指摘の通り以下になります。

・Cさん：
　　　・最大値→国語と英語の80
　　　　優先順位で国語が上位にあるため、国語を取得。
　　　・2番目→英語を取得。

>・Cさん： >・2番目→数学と理科の60？？ 国語と英語の80であれば、数学と理科の60は2番目じゃなくて3番目なんじゃ？
>・Cさん：
>・2番目→数学と理科の60？？

国語と英語の80であれば、数学と理科の60は2番目じゃなくて3番目なんじゃ？