Excel 各クラスによるランキングの合計 VBA

質問

団体は全部で12支部あります。
メン
1位　8点
2位　7点
3位　6点
4位　5点

以下各クラス（5つ）
1位　4点
2位　3点
3位　2点
4位　1点

リレー
1位　5点
2位　4点
3位　3点
4位　2点
5位　1点

Gセルに各順位、Iセルに各得点の合計で順位を並べたいです。
宜しくお願いします。

回答No.4

kkkkkm · ベストアンサー

> 「コンパイルエラー
> SubまたはFuncionが定義されていません」
> とエラーメッセージが出ます…

どこで出るのか記載が無いと想像しかできません。

Function SetTotalRanking(ByVal tRow As Long)
がないのではないですか。
同じなので省略してますから元のものを利用してください。

お礼

Function SetTotalRanking(ByVal tRow As Long)
を追加しましたら、正常に動きました。
ありがとうございました。

回答No.3

kkkkkm

> リレーのところが5位までなのですが、4位までとなっていますが

画像が4位まででしたので他と合わせました。

> 4大会にした場合、
> LastRow = Cells(Rows.Count, "G").End(xlUp).Row
> For j = tCol To tCol + 3
> としたのですが、正解でしょうか？

そうですね。その上の

For i = tRow To tRow + 8 Step 4
略
Next
Range(Cells(tRow, "G"), Cells(tRow + 11, "G")).RemoveDuplicates Columns:=1,
の部分も変更しないとデータのコピーが不足します。

一応、上記の部分を全て引数にして対応するコードにしてみました。
SetRanking内のコメントの部分が最初のコードでそこを変更しています。

(SetTotalRankingは変更がないので記載していません)

Sub Test()
Dim i As Long, j As Long, k As Long
Dim LastRow As Long

Range("G:J").ClearContents
Range("G1").Value = "順位"
Range("I1").Value = "総合順位"

' 説明 ここも変更
' Call SetRanking(各データ最上部の行番号, 1大会の列番号, 最高得点,最下位,大会数)
Call SetRanking(2, 3, 8, 4, 4)
Call SetRanking(15, 3, 4, 4, 4)
Call SetRanking(28, 3, 5, 5, 4)

' Call SetTotalRanking(データ最上部の行番号)
Call SetTotalRanking(2)
End Sub

'Function SetRanking(ByVal tRow As Long, ByVal tCol As Long, ByVal tScore As Long)
Function SetRanking(ByVal tRow As Long, ByVal tCol As Long, ByVal tScore As Long, ByVal LRank As Long, ByVal NumT As Long)
Dim i As Long, j As Long, k As Long
Dim LastRow As Long

j = tCol
' For i = tRow To tRow + 8 Step 4
For i = tRow To tRow + (LRank * NumT - LRank) Step LRank
' Cells(i, "G").Resize(4, 1).Value = Cells(tRow, j).Resize(4, 1).Value
Cells(i, "G").Resize(LRank, 1).Value = Cells(tRow, j).Resize(LRank, 1).Value
j = j + 1
Next
'Range(Cells(tRow, "G"), Cells(tRow + 11, "G")).RemoveDuplicates Columns:=1, Header:=xlNo
Range(Cells(tRow, "G"), Cells(tRow + (NumT * LRank - 1), "G")).RemoveDuplicates Columns:=1, Header:=xlNo

LastRow = Cells(Rows.Count, "G").End(xlUp).Row
'For j = tCol To tCol + 2
For j = tCol To tCol + (NumT - 1)
'For k = 1 To 4
For k = 1 To LRank
For i = tRow To LastRow
If Cells(k + (tRow - 1), j).Value = Cells(i, "G").Value Then
Cells(i, "H").Value = Cells(i, "H").Value + (tScore + 1 - k)
Exit For
End If
Next i
Next k
Next j
Range(Cells(tRow, "G"), Cells(LastRow, "H")).Sort _
Key1:=Cells(tRow, "H"), Order1:=xlDescending, _
Header:=xlNo
End Function

お礼

ありがとうございます。
実行してみましたところ、
「コンパイルエラー
SubまたはFuncionが定義されていません」
とエラーメッセージが出ます…

回答No.2

kkkkkm

画像を削除したほうの質問は回答が付かない間に削除したほうがいいと思います。回答が付くと削除できなくなります。

回答No.1

kkkkkm

前回の回答を一部変更したものです。

> 団体は全部で12支部あります。

> 以下各クラス（5つ）

この点がよくわかりませんので、画像の状態での結果です。

A列の点表示はその点数で計算しているという事ですが、目視点検用に入れていますので、なくても問題はありません。
一部県名を変更しています。

Sub Test()
Dim i As Long, j As Long, k As Long
Dim LastRow As Long

Range("G:J").ClearContents
Range("G1").Value = "順位"
Range("I1").Value = "総合順位"

' 説明
' Call SetRanking(各データ最上部の行番号, 1大会の列番号, 最高得点)
Call SetRanking(2, 3, 8)
Call SetRanking(15, 3, 4)
Call SetRanking(28, 3, 5)

' Call SetTotalRanking(データ最上部の行番号)
Call SetTotalRanking(2)
End Sub

Function SetRanking(ByVal tRow As Long, ByVal tCol As Long, ByVal tScore As Long)
Dim i As Long, j As Long, k As Long
Dim LastRow As Long

j = tCol
For i = tRow To tRow + 8 Step 4
Cells(i, "G").Resize(4, 1).Value = Cells(tRow, j).Resize(4, 1).Value
j = j + 1
Next
Range(Cells(tRow, "G"), Cells(tRow + 11, "G")).RemoveDuplicates Columns:=1, Header:=xlNo

LastRow = Cells(Rows.Count, "G").End(xlUp).Row
For j = tCol To tCol + 2
For k = 1 To 4
For i = tRow To LastRow
If Cells(k + (tRow - 1), j).Value = Cells(i, "G").Value Then
Cells(i, "H").Value = Cells(i, "H").Value + (tScore + 1 - k)
Exit For
End If
Next i
Next k
Next j
Range(Cells(tRow, "G"), Cells(LastRow, "H")).Sort _
Key1:=Cells(tRow, "H"), Order1:=xlDescending, _
Header:=xlNo
End Function

Function SetTotalRanking(ByVal tRow As Long)
Dim i As Long, j As Long, k As Long
Dim LastRowI As Long, LastRowG As Long

LastRowG = Cells(Rows.Count, "G").End(xlUp).Row
Cells(tRow, "I").Resize(LastRowG, 1).Value = Cells(tRow, "G").Resize(LastRowG, 1).Value
Range(Cells(tRow, "I"), Cells(LastRowG, "I")).RemoveDuplicates Columns:=1, Header:=xlNo

LastRowI = Cells(Rows.Count, "I").End(xlUp).Row
For k = tRow To LastRowG
For i = tRow To LastRowI
If Cells(k, "G").Value = Cells(i, "I").Value _
And Cells(k, "G").Value <> "" Then
Cells(i, "j").Value = Cells(i, "j").Value + Cells(k, "H").Value
Exit For
End If
Next i
Next k
Range(Cells(tRow, "I"), Cells(LastRowI, "J")).Sort _
Key1:=Cells(tRow, "J"), Order1:=xlDescending, _
Header:=xlNo
End Function

お礼

いつもありがとうございます。
リレーのところが5位までなのですが、4位までとなっていますが。

補足

4大会にした場合、
LastRow = Cells(Rows.Count, "G").End(xlUp).Row
For j = tCol To tCol + 3
としたのですが、正解でしょうか？