順位の計算(VBA):エクセル練習問題

解答例　　　　topへ

問題1の解答例　　　　 topへ

	B	C	D	E
2	名前	性別	得点	順位
3	相沢一郎	男	52	7
4	井上浩二	男	74	5
5	上野有紀	女	84	1
6	内野武	男	77	2
7	上田祥子	女	68	6
8	江田早苗	女	77	2
9	榎本高貴	男	77	2
10	小田和樹	男	47	8

ワークシート関数を使って計算した例です。

ワークシート関数RANKをVBAで使う時はApplication.WorksheetFunction.Rank　とします。

Sub test10()
　　Dim c As Range
　　　　For Each c In Range("D3:D10")
　　　　　　c.Offset(0, 1).Value = Application.WorksheetFunction.Rank(c.Value, Range("D3:D10"))
　　　　Next c
End Sub

For～Nextで値を比較して順位を求めることも可能です。
ただし、データ数が多いと繰り返し回数が多くなり、時間がかかってしまいますので実用的ではありません。

Sub test12()
　　Dim i As Long, j As Long
　　Dim myRank As Long
　　　　For i = 3 To 10
　　　　　　myRank = 1
　　　　　　For j = 3 To 10
　　　　　　　　If Cells(i, 4).Value < Cells(j, 4).Value Then
　　　　　　　　　　myRank = myRank + 1
　　　　　　　　End If
　　　　　　Next j
　　　　　　Cells(i, 5).Value = myRank
　　　　Next i
End Sub

問題2の解答例　　　　 topへ

	B	C	D	E
2	名前	性別	得点	順位
3	相沢一郎	男	52	7
4	井上浩二	男	74	5
5	上野有紀	女	84	1
6	内野武	男	77	2
7	上田祥子	女	68	6
8	江田早苗	女	77	3
9	榎本高貴	男	77	4
10	小田和樹	男	47	8

ワークシート関数を使ったコードの例です。

数式の例：同点が上のデータにあるか否かをCOUNTIF関数で調べます。
同点が2個あれば、2つ目の同点者はRANK関数で求めた順位+1　となりますので、+COUNTIF($D$3:D3,D3)-1　と補正します。
E3セルは　=RANK(D3,$D$3:$D$10)+COUNTIF($D$3:D3,D3)-1　となります。

Sub test20()
　　Dim i As Long
　　　　For i = 3 To 10
　　　　　　Cells(i, 6).Value = Application.WorksheetFunction.Rank(Cells(i, 4).Value, Range("D3:D10")) _
　　　　　　　　　　　　　　+ Application.WorksheetFunction.CountIf(Range("D3:D" & i), Cells(i, 4).Value) - 1
　　　　Next i
End Sub

問題3の解答例　　　　 topへ

	B	C	D	E	F	G	H
2	名前	性別	得点	順位		順位	名前
3	相沢一郎	男	52	7		1位	上野有紀
4	井上浩二	男	74	5		2位	内野武
5	上野有紀	女	84	1		3位	江田早苗
6	内野武	男	77	2		4位	榎本高貴
7	上田祥子	女	68	6
8	江田早苗	女	77	3
9	榎本高貴	男	77	4
10	小田和樹	男	47	8

得点の最高点100から1点ずつ該当者を捜し、3人目の得点までを書き出しています。
3人を超えたらループから抜けています。

Findメソッドについては　Excel(エクセル) VBA入門：Findメソッド,Like演算子を使った検索　をご覧ください。
下記のコードの一部を 2020/4/9にメールにて質問を頂き、間違いに気づきましたので修正しました。

Sub test30()

　　Dim c As Object
　　Dim myKey As Long, fAddress As String
　　Dim myCnt As Long, tokuten As Long
　　Dim i As Long
　　　　Range("G3:H10").ClearContents
　　　　With Range("D3:D10")
　　　　　　For i = 100 To 0 Step -1
　　　　　　　　myKey = i
　　　　　　　　If myCnt >= 3 Then Exit For　’And myKey < tokuten　を消しました2020/4/9
　　　　　　　　　　Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlWhole, _
　　　　　　　　　　　　　　　　SearchOrder:=xlByColumns, MatchByte:=False)
　　　　　　　　　　If Not c Is Nothing Then
　　　　　　　　　　　　fAddress = c.Address
　　　　　　　　　　　　Do
　　　　　　　　　　　　　　myCnt = myCnt + 1
　　　　　　　　　　　　　　'tokuten = i 　←2020/4/9修正しました
　　　　　　　　　　　　　　Cells(myCnt + 2, 7).Value = myCnt & "位"
　　　　　　　　　　　　　　Cells(myCnt + 2, 8).Value = c.Offset(0, -2).Value

　　　　　　　　　　　　　　Set c = .FindNext(c)
　　　　　　　　　　　　　　If c.Address = fAddress Then Exit Do
　　　　　　　　　　　　Loop
　　　　　　　　End If
　　　　　　Next i
　　　　End With
End Sub

得点を降順に並べ替え、上位の得点の人を順次書き出します。3人以上となる得点までで終了としています。
なお、下記リンク先のコードを流用していますので、ここの例は3つのコード群から成り立っています。

並べ替えにはクイックソートを利用しています。詳しくはExcel(エクセル) VBA入門：配列の並べ替えをご覧ください。

重複なしデータを取得しています。ここで並べ替えや書き出しのサブルーチンを実行しています。

Sub Q_D_Sort()
　　Dim myData
　　Dim S_Data
　　Dim myDic As Object
　　Dim x() As Variant
　　Dim D As Variant
　　Dim L As Long
　　Dim U As Long
　　Dim i As Long
　　　'----データ範囲を指定する
　　　myData = Range(Cells(3, 4), Cells(10, 4)).Value

　　　'----重複なしの値をDictionaryで取り出す
　　　Set myDic = CreateObject("Scripting.Dictionary")
　　　　For Each D In myData
　　　　　　If Not D = Empty Then
　　　　　　　　If Not myDic.Exists(D) Then
　　　　　　　　　　myDic.Add D, ""
　　　　　　　　End If
　　　　　　End If
　　　　Next D
　　　　x = myDic.keys
　　　　Set myDic = Nothing

　　'----Q_Sortで並べ替える
　　L = LBound(x)
　　U = UBound(x)
　　Call Q_Sort(x, L, U)

　　'----データの書き出し
　　Call out_put(x)

End Sub

並べ替えのプログラムです。クイックソートです。

Sub Q_Sort(ByRef myData() As Variant, ByVal L As Long, ByVal U As Long)
　　Dim i As Long
　　Dim j As Long
　　Dim S As Variant
　　Dim Tmp As Variant
　　　　S = myData(Int((L + U) / 2))
　　　　i = L
　　　　j = U
　　Do
　　　　' Do While myData(i) < S ’昇順
　　　　Do While myData(i) > S '降順
　　　　　　i = i + 1
　　　　Loop
　　　　' Do While myData(j) > S ’昇順
　　　　Do While myData(j) < S '降順
　　　　　　j = j - 1
　　　　Loop
　　　　If i >= j Then Exit Do
　　　　Tmp = myData(i)
　　　　myData(i) = myData(j)
　　　　myData(j) = Tmp
　　　　i = i + 1
　　　　j = j - 1
　　Loop
　　If (L < i - 1) Then Q_Sort myData, L, i - 1
　　If (U > j + 1) Then Q_Sort myData, j + 1, U
End Sub

データの書き出し部分のプログラムです。

Sub out_put(ByRef x() As Variant)
　　Dim c As Object
　　Dim myKey As Long, fAddress As String
　　Dim myCnt As Long, tokuten As Long
　　Dim i As Long
　　　　Range("G3:H10").ClearContents
　　　　With Range("D3:D10")
　　　　　　For i = 0 To 2
　　　　　　　　myKey = x(i)
　　　　　　　　If myCnt >= 3 Then Exit For

　　　　　　　　Set c = .Find(What:=myKey, LookIn:=xlValues, lookat:=xlWhole, _
　　　　　　　　　　　　　SearchOrder:=xlByColumns, MatchByte:=False)
　　　　　　　　If Not c Is Nothing Then
　　　　　　　　　　fAddress = c.Address
　　　　　　　　　　Do
　　　　　　　　　　　　myCnt = myCnt + 1
　　　　　　　　　　　　Cells(myCnt + 2, 7).Value = myCnt & "位"
　　　　　　　　　　　　Cells(myCnt + 2, 8).Value = c.Offset(0, -2).Value

　　　　　　　　　　　　Set c = .FindNext(c)
　　　　　　　　　　　　If c.Address = fAddress Then Exit Do
　　　　　　　　　　Loop
　　　　　　　　End If
　　　　　　Next i
　　　　End With
End Sub

エクセル練習問題：順位の計算（VBA)

問題　　　　　topへ

解答例　　　　topへ

問題1の解答例　　　　 topへ

問題2の解答例　　　　 topへ

問題3の解答例　　　　 topへ

スポンサードリンク

エクセル練習問題：順位の計算（VBA)

問題 topへ

解答例 topへ

問題1の解答例 topへ

問題2の解答例 topへ

問題3の解答例 topへ

問題　　　　　topへ

解答例　　　　topへ

問題1の解答例　　　　 topへ

問題2の解答例　　　　 topへ

問題3の解答例　　　　 topへ