エクセルでの成績処理

質問

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

エクセル2003です。
成績処理のマクロを教えてください。
以下の表があります。

NO.　　　名前　　　国　　　算　　　理　　　国語クラス　　算数クラス　　理科クラス
1　　　　　A　　　100　　　75　　　80　　　　1　　　　　　　2　　 2
2　　　　　B　　　70　　　 85　　　90　　　　2　　　　　　　3　 　1
3　　　　　C　　　100　　　75　　　95　　　　1　　　　　　　1　 　1
4　　　　　D　　　85　　　 95　　　85　　　　3　　　　　　　2　 　3
5　　　　　E　　　75　　　 80　　　75　　　　2　　　　　　　1　 　2
6　　　　　F　　　85　　　 70　　　90　　　　3　　　　　　　2　　 1
7　　　　　G　　　100　　　90　　　80　　　　1　　　　　　　1　 　3
8　　　　　H　　　95　　 　85　　　90　　　　2　　　　　　　3　　 2
9　　　　　I　　　100　　　85　　　70　　　　1　　　　　　　3　　 3

数字がずれてすみません。
Ａ列に連番、Ｂ列に名前、Ｃ-Ｅ列に教科ごとの点数、Ｆ-Ｈ列に教科ごとの所属クラス
実際は150名分のデータでクラスも多いですが。
この表から各教科の点数の上位３位までのクラス別順位表を作りたいのです。
その際に、順位も名前の左側につけたいです。（同セル内でも、名前セルの左でもかまいません）
同順位であれば連番の昇順で。

つまり
国語１クラス
1 A
2 C
3 G
4 I

国語２クラス
1 H
2 E
3 B

という具合に、できれば、別シートにマクロで出すコードを教えてください。
勝手ながら、人数が増えても応用しやすいものだと助かります。
現在はオートフィルでの手作業をしています。

回答No.2

noname#192382 · ベストアンサー

マクロでやってみました。すごく行数が多くて、ここに乗せることが許されるか心配ですが、一応お送りします。シート1のデータをシート2にコピーしてしーと2を使って計算し、答えをしーと3に書くようにしています。

Sub Macro3()
'
' Macro3 Macro
' マクロ記録日 : 2011/2/26 ユーザー名 :
'

'
Application.CutCopyMode = False
Sheets("Sheet2").Select
Range("A1:H10").Select
Selection.AutoFilter
Selection.AutoFilter Field:=6, Criteria1:="1"
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("A2:B10").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=6, Criteria1:="2"
Range("A3:B9").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A7").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=6, Criteria1:="3"
Range("A5:B7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A12").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=6
Selection.AutoFilter Field:=7, Criteria1:="1"
Range("A4:H8").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("D4"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("A4:B8").Select
Selection.Copy
Sheets("Sheet3").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=7, Criteria1:="2"
Range("A2:B7").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("D7").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=7, Criteria1:="3"
Range("A3:H10").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("D3"), Order1:=xlDesce

回答No.5

tom04

No.4です！
続きのコードです。

'ここから前回のコードの続きになります。

For j = 13 To 19 Step 3
For i = 2 To k
On Error Resume Next
ws1.Cells(i, j) = WorksheetFunction.Rank(ws1.Cells(i, j - 1), _
Range(ws1.Cells(2, j - 1), ws1.Cells(k, j - 1)))
Next i
Next j
For j = 13 To 19 Step 3
For i = ws1.Cells(Rows.Count, j).End(xlUp).Row To 3 Step -1
If ws1.Cells(i, j) > 3 Then
Range(ws1.Cells(i, j - 2), ws1.Cells(i, j)).Delete (xlUp)
End If
Next i
Next j
For j = 11 To 17 Step 3
Range(ws1.Cells(2, j), ws1.Cells(k, j + 2)).Sort key1:=ws1.Cells(2, j + 2), order1:=xlAscending
Next j

For j = 11 To 17 Step 3
For i = 1 To ws1.Cells(Rows.Count, j).End(xlUp).Row
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, j)
If ws1.Cells(i, j + 1) = "" Then
.Offset(, 1) = ""
Else
.Offset(, 1) = ws1.Cells(i, j + 2) & "位"
End If
End With
Next i
Next j
ws1.Range("I:S").Delete
Next H
ws2.Columns("A:B").AutoFit
For i = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws2.Cells(i, 2) = "" Then
ws2.Cells(i, 1).Interior.ColorIndex = 6
End If
Next i
End Sub 'この行まで

こんなんではどうでしょうか？
他に良い方法があればごめんなさいね。m(__)m

お礼

tom04　様　ありがとうございました。
無学なもので無茶なお願いをしてしまいました。
大変なお手間を取らせて申し訳ありませんでした。
勉強しながら大切に使わせていただきます。
簡単で恐縮ですが、お礼申し上げます。

回答No.4

tom04

こんばんは！
無理矢理って感じでやってみました。
Sheet1にデータがありSheet2に表示するようにしています。

For～Nextを多用していますので、時間がかかるかもしれません。
尚、人数が増えても対応できると思いますが、科目数が増える場合はコードの手直しが必要になります。

それから、2000文字を超えるようなので2度に分けてコードを投稿してみます。

まず前半のコードです。

Sub test() 'この行から
Dim ws1, ws2 As Worksheet
Dim H, i, j, k As Long
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Dim c As Range
For Each c In ws2.UsedRange
c.Clear
Next c
k = ws1.Cells(Rows.Count, 1).End(xlUp).Row
For H = 6 To 8
For i = 2 To k
ws1.Cells(i, 9) = ws1.Cells(1, H) & ws1.Cells(i, H)
If WorksheetFunction.CountIf(Range(ws1.Cells(2, 9), ws1.Cells(i, 9)), ws1.Cells(i, 9)) = 1 Then
ws1.Cells(Rows.Count, 10).End(xlUp).Offset(1) = ws1.Cells(i, 9)
End If
Next i
Range(ws1.Cells(2, 10), ws1.Cells(k, 10)).Sort key1:=ws1.Cells(2, 10), order1:=xlAscending
For i = 2 To ws1.Cells(Rows.Count, 10).End(xlUp).Row
ws1.Cells(1, Columns.Count).End(xlToLeft).Offset(, 3) = ws1.Cells(i, 10)
Next i
For i = 2 To k
For j = 11 To 17 Step 3
If ws1.Cells(i, 9) = ws1.Cells(1, j) Then
With ws1.Cells(Rows.Count, j).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 2)
.Offset(, 1) = ws1.Cells(i, 3)
End With
End If
Next j
Next i
'2000文字を超えるようなのでここで一旦切ります

まずはここまで・・・m(__)m

回答No.3

noname#192382

まくろを全部乗せられませんでしたので続きを少しダブって載せます。
Range("A3:H10").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("D3"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("A3:B10").Select
Selection.Copy
Sheets("Sheet3").Select
Range("D12").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=7
Selection.AutoFilter Field:=8, Criteria1:="1"
Range("A3:H8").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("E3"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("A3:B8").Select
Selection.Copy
Sheets("Sheet3").Select
Range("G1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=8, Criteria1:="2"
Range("A2:H9").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("A2:B9").Select
Selection.Copy
Sheets("Sheet3").Select
Range("G7").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=8, Criteria1:="3"
Range("A4:H10").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("E4"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
Range("A4:B10").Select
Selection.Copy
Sheets("Sheet3").Select
Range("G12").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Selection.AutoFilter Field:=8
End Sub

お礼

optimumsoup 様　ありがとうございました。
素人の怖さで無茶な依頼をしてしまいました。
大変お手間を取らせて申し訳ありません。
勉強しながら大切に使わせていただきます。
簡単で恐縮ですが、お礼申し上げます。

回答No.1

hallo-2007

マクロではありませんが
関数の組み合わせで処理してみました
仮に　別シート（シート名　成績順位として）に
　　A　　B　　　C
１　　　科目　　国
２　　　クラス　１
３　　　点数　　氏名
４
と準備します。
C1セルに　表示したい　科目　　例では　国
C2セルに　表示したい　クラス　例では　１
と入れておきます。
実際のデータのシート（仮に　シート名　データ　として）
NO.　　　名前　　　国　　　算　　　理　　　国語クラス　　算数クラス　　理科クラス
の後に（仮に　J列に）
J2セルに
=IF(OFFSET(E2,0,MATCH(成績順位!C$1,C$1:E$1,FALSE))=成績順位!C$2,OFFSET(B2,0,MATCH(成績順位!C$1,C$1:E$1,FALSE))-A2/1000,"")
一番下までコピーしておきます。
ここで　成績順位のシートに　科目に　国　クラスに　１と入れた場合　その条件にあった点数が出るはずです。
更に　その点数は　微妙に差をつけるため　連番の1/1000を引き算しておきます。
科目とクラスを　算　とか　２　とかにして表示の違いを確認してみてください。
OFFSET関数と MATCH関数を何度も使っていて複雑にみえますが
良く考えてみると　あっそ～　と思われると思います。
それぞれの関数の意味は　Helpで確認してみてください。
もし意味が難しかったら
K列に
=MATCH(成績順位!C$1,C$1:E$1,FALSE) と入れて下までコピーしてみてください。
出したい科目のデータが左から何列ずれた列にあるかが　数字で出ます。
J列は
=IF(OFFSET(E2,0,K2)=成績順位!C$2,OFFSET(B2,0,K2)-A2/1000,"")
とすることも出来ます。

あとは
成績順位のシートの　B4セルに
=IF(ISERROR(LARGE(データ!J:J,ROW(A1))),"",LARGE(データ!J:J,ROW(A1)))
C4セルに
=IF(B3="","",INDEX(データ!B:B,MATCH(B3,データ!J:J,FALSE)))
といれて下までコピーしてください。
成績順に点数と名前が出ます。
点数が端数まで出るので　表示形式で　小数点以下を表示しない　にすればOKです。
シートも　データと結果表示のための成績順位というシートの2枚で完成できます。
データを入れるだけで結果が出ますしマクロで実行するより使いやすいと思います。
印刷などで　列や行を挿入したときも自動で関数式が変わってくれるので便利です。

お礼

hallo-2007 様　ありがとうございました。
関数を作っていただき助かりました。
関数ではできないと思い込んでいたものですから。
マクロより使いやすいとのことで勉強になりました。
大切に使わせていただきます。