文字検索について

質問

エクセル内のシートに表を作成しています。
A2：A6に各氏名（田中・佐藤・鈴木・石橋・内藤、５名分）。
B1：F1に各教科（国・数・社・理・英、５科目）。
セルB2：F6内に各者の教科別点数を入力しています。
『この表ではA1の部分は空白となっています』

そして、今回行いたい内容としては、
セルB2:F6内の点数を多い順から別の表に抜き出し、
同時に該当する点数の氏名と教科を、点数の入ったセルの
左となりに抜き出したいと考えてます。
例えば、B2のセルに１００点が入り全体でTOP1の場合は
別表に氏名（田中）、教科（国）、点数１００点と
並べて抜き出すということです。
この用に、TOP1～TOP5を縦に並べ抜き出したいと考えております。

幾度も挑戦したのですが、私の力ではどうもなりませんでした。
どうぞ宜しくお願いします。

回答No.3

AKARI0418 · ベストアンサー

今回の質問は提示したソースを少しいじれば実現できるものです。
ご自分で改造なされたほうが良いと思います。ソースへの理解も深まりますし、もっと業務に適した改造ができると思います。
ただ、乗りかけた船ですので、参考までに回答いたします。

名前のリスト順に各教科を判別していき、順位の高い順に出力していきます。
つまり全員100点の場合、TOP1は名前リストの１番目の１教科目が出力され、ついで２教科目３教科目と出力されます。

ソースは以下のとおりです。
ループの回り方が変わっていますので混同しないように注意してください。

Sub TopRankOut()
'名前行
Const NameColumn As Long = 1
'教科列
Const KyokaRow As Long = 1
'点数データ位置
Const StartRow As Long = 2
Const StartColumn As Long = 2
'教科数
Const KyokaCount As Long = 5
'処理人数
Const MemberCount As Long = 5
'別表書き出し位置
Const SammaryRow As Long = 1
Const SammaryColumn As Long = 1
Const SammarySheet As String = "Sheet2"
'上位何名出力するかの設定
Const OutTop As Long = 5

Dim i As Long, j As Long
Dim EndRow As Long
Dim EndCol As Long
Dim Rank As Long
Dim Workrange As Excel.range
Dim SetRow As Long
Dim SetColumn As Long
Dim MaxRow As Long

EndRow = StartRow + MemberCount - 1
EndCol = StartColumn + KyokaCount - 1

Set Workrange = range(Cells(StartRow, StartColumn), Cells(EndRow, EndCol))
'最終出力位置設定
MaxRow = OutTop + SammaryRow - 1

For i = StartRow To EndRow
For j = StartColumn To EndCol
'Excelランク関数の順位をもとに処理します。
Rank = WorksheetFunction.Rank(Cells(i, j).Value, Workrange, 0)
'上位OutTop以内は出力対象
If OutTop >= Rank Then
'別表書き出し位置計算
SetRow = Rank - 1 + SammaryRow
SetColumn = SammaryColumn
'RANK関数は同順位がつくため、すでにデータがある場合書き出し位置をずらす
Do While Sheets(SammarySheet).Cells(SetRow, SetColumn).Value <> vbNullString
SetRow = SetRow + 1
Loop
'最終出力数いないであれば出力する
If SetRow <= MaxRow Then
'順位書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = StrConv(Rank, vbWide) & "位"
SetColumn = SetColumn + 1
'名前書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = Cells(i, NameColumn).Value
SetColumn = SetColumn + 1
'教科書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = Cells(KyokaRow, j).Value
SetColumn = SetColumn + 1
'点数書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = Cells(i, j).Value
End If
End If
Next j
Next i
Set Workrange = Nothing
End Sub

お礼

ありがとうございます。
正直、このアプリを理解しきれていませんが
教示頂いたソースについて一から勉強したいと思います。
お力添え深く感謝致します。

回答No.2

AKARI0418

点数などのデータのあるシートで実行してください。
シート２にTOP1～TOP5を縦に並べ抜き出す用に作ってあります。
定数を変数化するなど工夫して使ってください。
疑問がありましたら質問してください。

Sub Rank()
'名前行
Const NameColumn As Long = 1
'教科列
Const KyokaRow As Long = 1
'点数データ位置
Const StartRow As Long = 2
Const StartColumn As Long = 2
'教科数
Const KyokaCount As Long = 5
'処理人数
Const MemberCount As Long = 5
'別表書き出し位置
Const SammaryRow As Long = 1
Const SammaryColumn As Long = 1
Const SammarySheet As String = "Sheet2"

Dim i As Long, j As Long
Dim EndRow As Long
Dim EndCol As Long
Dim Rank As Integer
Dim Workrange As Excel.range
Dim SetRow As Integer
Dim SetColumn As Integer

EndRow = StartRow + MemberCount - 1
EndCol = StartColumn + KyokaCount - 1

For i = StartColumn To EndCol
Set Workrange = range(Cells(StartRow, i), Cells(EndRow, i))
For j = StartRow To EndRow
'Excelランク関数の順位をもとに処理します。
Rank = WorksheetFunction.Rank(Cells(j, i).Value, Workrange, 0)
'別表書き出し位置計算
SetRow = Rank - 1 + SammaryRow
SetColumn = SammaryColumn + (i - StartColumn) * 3
'RANK関数は同順位がつくため、すでにデータがある場合書き出し位置をずらす
Do While Sheets(SammarySheet).Cells(SetRow, SetColumn).Value <> vbNullString
SetRow = SetRow + 1
Loop
'名前書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = Cells(j, NameColumn).Value
SetColumn = SetColumn + 1
'教科書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = Cells(KyokaRow, i).Value
SetColumn = SetColumn + 1
'点数書き出し
Sheets(SammarySheet).Cells(SetRow, SetColumn).Value = Cells(j, i).Value
Next j
Set Workrange = Nothing
Next i
End Sub

補足

ご挨拶が遅れ申し訳ありません。
アプリまで作成して頂き有難うございます。
申し訳ありませんが、再度ご教示下さい。

このマクロを使い、教科毎ではなく氏名・教科・点数を
まとめたうえでTOP５を算出することはできますか。

実際に使わせて頂いたのですが、できれば全者・全教科での
TOP５をだしたいのです。同点の場合は、

１位　田中　国　１００点
１位　鈴木　数　１００点
３位　佐藤　英　９７点
４位　田中　数　９５点
５位　内藤　国　９３点
という形です。

あつかましいお願いとなりますが、どうぞ宜しくお願い致します。

回答No.1

n-jun

＞幾度も挑戦したのですが
その方法を提示された方が重複しなくて済みそうですけど。
あと同じ点数の処理をどうするのかと、ＶＢＡ（ＶＢ？）でやるという事ですか？