スキルアップ・問題解決なら、モーグにおまかせ！

次のような同店がる成績の場合の順位付けとして、
worksheetfaunction のrank関数を使うよりcountifsを使う
とありすが、よくわからいので、お願いします。
合計が同じ場合、次は国語の点数、それでも同じ場合は社旗、数学、理科の順に
順位をつけたいと思います。
A列　　B列　　C列　　D列　　　E列　　　F列　　　G列
番号    国語    社会    数学    理科    合計　　順位
1    59    64    55    44    222 3
2    59    65    50    48    222 2
3    57    63    53    47    220 5
4    57    63    53    48    221 4
5    57    63    52    48    220 6
6    60    64    53    46    223　　 1
・
・
 
人数は講座よって毎回変わります。
ｇ列に入れる数式は次のようなると思うのですが、
RANK(f3,$f$3:$f$)+COUNTIF(f3:$ｆ$,f3)-1
VBA初心者でよくわかりません。
 
 

VBAを使われるなら、数式もよいですけど、
優先順位に従って複数のキーを使ったソートを行い、
並び替えた結果に上から1,2,3　と「順位」を振ればよいのでは？
最後に「番号」でソートして元に戻します。
マクロ記録をとって手を入れればよいでしょう。

例えば、合計*100+ 国語 + 社会*0.01 + 数学*0.0001+ 理科*0.000001
のような換算点を計算して、それに対してrank計算(降順）で「順位」が計算できるのでは？
 
どうしても計算式でされたいのであれば、
ポイントはVBAじゃなく計算式の作成ですから、
VBAの質問板よりも、一般機能の板で尋ねたほうがコメントが集まるんじゃないですか？

＞次のような同点がある成績の場合の順位付けとして、
 
対象となる実データの素性を明確にして貰った方がよさそうな気がしないでもない。
※「あくまで例なので、実際は別」とか言われると疲れが出ます)
 
つまり、成績とやらは0〜100の整数で合計は高々400と言うことになりますが、
実データもその通りなのでしょうか？

半平太 さんの引用:
＞次のような同点がある成績の場合の順位付けとして、
 
対象となる実データの素性を明確にして貰った方がよさそうな気がしないでもない。
※「あくまで例なので、実際は別」とか言われると疲れが出ます)
 
つまり、成績とやらは0〜100の整数で合計は高々400と言うことになりますが、
実データもその通りなのでしょうか？

simple さんの引用:
例えば、合計*100+ 国語 + 社会*0.01 + 数学*0.0001+ 理科*0.000001
のような換算点を計算して、それに対してrank計算(降順）で「順位」が計算できるのでは？
 
どうしても計算式でされたいのであれば、
ポイントはVBAじゃなく計算式の作成ですから、
VBAの質問板よりも、一般機能の板で尋ねたほうがコメントが集まるんじゃないですか？

＞科目数は増えますので、合計は1000点程度になります。
 
10科目あるとすると、これは無理です。(エクセルの有効桁数は15桁しかないので）
　　　　　　　　　　　↓
＞×を使ったものを一度考えてみます。
 
素直に、ソートするのが無難と思います。

N2
=TEXT(L2,"0000")&TEXT(B2,"000")&TEXT(C2,"000")&TEXT(D2,"000")&TEXT(E2,"000")&TEXT(F2,"000")&TEXT(G2,"000")&TEXT(H2,"000")&TEXT(I2,"000")&TEXT(J2,"000")&TEXT(K2,"000")
下方向・↓　と連結しておいて
 
　　B　 C　 D　 E　 F　　G　 H　 I　 J　 K　　 L　 M　　　　　N
1　国　社　数　理　英　 数　地　公　化　物　合計　順　　　　　　　　　　　　　　　　　　
2　59　64　55　44　47　 77　83　69　52　89　 639　 2　0639059064
3　59　65　50　48　67　 93　34　87　44　92　 639　 1　0639059065
4　57　63　53　47　36　100　42　74　54　84　 610　 5　0610057063
5　57　63　53　48　71　 59　66　99　67　56　 639　 3　0639057063
6　57　63　55　48　58　 59　94　83　60　33　 610　 4　0610057063
7　60　64　53　46　72　 44　48　75　39　47　 548　 6　0548060064
 
M2
=COUNTIF(N$2:N$500,">"&N2&"""")+1
下方向・↓
 
最新のExcelなら　N2
=CONCAT(TEXT(L2,"0000"),TEXT(B2:K2,"000"))

最新のExcelならこっちでした。作業列不要。
 
M2
=MATCH(A2,INDEX(SORT($A$2:$L$500,{12,2,3,4,5,6,7,8,9,10,11},-1),,1),0)

物理まで見る必要あるんですかねぇ・・
 
そこまで見ないと差が出ないケースは、既に合計で差がついているハズだと思うのですが。

＜準備＞
�@以下のコードを標準モジュールにコピペしてください。
�A場所はどこでも良いので、優先順位を記載した表を作成してください。
　以下例のI列に該当します。表の上から順に優先されます。
  ※優先順位は動的に変更できる方が良いと思いますので、表として外出しにしています。
　※優先順位の項目は2行目の科目名と完全一致としてください。
 
＜関数を入力＞
以下の例のG列に以下のように入力してください。
 =Scoring($B$1:$E$11,B2:E2,$I$2:$I$5)
 
オートフィルで一番下までコピーして完成です。
 
A列　　B列　　C列　　D列　　　E列　　　F列　　　G列　　　H列　　　I列
番号 国語 社会 数学 理科 合計　　順位　　　空列　　優先順位
1　　　59 　64　55　44 　 222　　　　　　　　　　　　国語
2　　　59 　65　50　48 　 222　　　　　　　　　　　　社会
3　　　57 　63　53　47 　 220　　　　　　　　　　　　数学
4　　　57 　63　53　48 　 221　　　　　　　　　　　　理科
5　　　57 　63　52　48 　 220
6　　　60 　64　53　46 　 223
・
・
 

Function Scoring(allRange As Range, targetRange As Range, priorityRange As Range)
    'allRange：科目名と点数記載された範囲を選択してください。（合計列などは不要です）
    'targetRange：順位を求めたい行範囲を選択してください。範囲は「allRange」と同じ列です。
    'priorityRange：科目の優先順位を記載した範囲を選択してください。記載順に上から優先されます。

    Dim rowRng As Range
    Dim rng As Range
    Dim sum As Integer
    Dim n As Integer, i As Integer
    Dim targetRow As Integer: targetRow = targetRange.Row - allRange.Row + 1
    Dim allRangeArr As Variant
    allRangeArr = allRange.Value2
    ReDim Preserve allRangeArr(1 To UBound(allRangeArr, 1), 1 To UBound(allRangeArr, 2) + 1)
    Dim sumCol As Integer: sumCol = UBound(allRangeArr, 2)
    
    '各行の合計を求める
    For i = LBound(allRangeArr, 1) + 1 To UBound(allRangeArr, 1)
        For n = LBound(allRangeArr, 2) To UBound(allRangeArr, 2) - 1
            allRangeArr(i, sumCol) = allRangeArr(i, sumCol) + allRangeArr(i, n)
        Next n
    Next i
    
    '対象行の合計を求める
    For Each rng In targetRange.Cells
        sum = sum + rng.Value
    Next rng
    
    '対象行の合計と同点の行が存在するか確認する
    Dim sameScoreCheck As Variant
    sameScoreCheck = UBound(Split(Join(WorksheetFunction.Index(WorksheetFunction.Transpose(allRangeArr), sumCol), ","), sum))
    
    If sameScoreCheck = 1 Then
        Scoring = GetRank(allRangeArr, sumCol, allRangeArr(targetRow, sumCol))
    Else
        Dim factor As Double
        For n = LBound(allRangeArr, 2) To UBound(allRangeArr, 2) - 1
            For i = LBound(allRangeArr, 1) To UBound(allRangeArr, 1)
                Dim a
                a = allRangeArr(i, n)
                If i = 1 Then
                    factor = 0.1 ^ (WorksheetFunction.Match(allRangeArr(i, n), priorityRange, 0) + 2) '係数を作成
                Else
                    allRangeArr(i, sumCol) = allRangeArr(i, sumCol) + allRangeArr(i, n) * factor '合計に科目点＊係数を足す
                End If
            Next i
        Next n
        Scoring = GetRank(allRangeArr, sumCol, allRangeArr(targetRow, sumCol))
    End If
End Function

Private Function GetRank(ByRef arr As Variant, ByVal targetCol As Integer, ByVal targetVal As Variant)
    
    Call SortArray(arr, targetCol, False) '降順にソートする
    
    Dim n As Long
    For n = LBound(arr, 1) To UBound(arr, 1)
        If arr(n, targetCol) = targetVal Then '対象値を発見したらその時点のnがランクとなり終了
            GetRank = n
            Exit For
        End If
    Next n

End Function

Private Sub SortArray(ByRef arr As Variant, ByVal targetCol As Integer, ByVal ascFlag As Boolean, Optional iLeft As Variant = -1, Optional iRight As Variant = -1)
    '2次配列を昇順または降順に並び替える
    
    If iLeft = -1 Then iLeft = LBound(arr)
    If iRight = -1 Then iRight = UBound(arr)
    
    Dim iMid As Variant '中央値
    iMid = arr(Int((iLeft + iRight) / 2), targetCol) '中央値を取得
    
    Dim i As Long: i = iLeft '左側の探索用変数
    Dim j As Long: j = iRight '右側の探索用変数
    Dim k As Long
    Dim vSwap As Variant

    Do
        If ascFlag = True Then
            '昇順並べ替え------------------
            Do While arr(i, targetCol) < iMid  '中央値から左側のループ
                i = i + 1  '中央値以上の値まで右側に探索していく
            Loop
            
            Do While iMid < arr(j, targetCol)
                j = j - 1
            Loop
        Else
            '降順並べ替え-------------------
            Do While arr(i, targetCol) > iMid
                i = i + 1
            Loop

            Do While iMid > arr(j, targetCol)
                j = j - 1
            Loop
        End If
        
        If i >= j Then Exit Do '左側探索と右側探索の位置が交差したら終了
        
        For k = LBound(arr, 2) To UBound(arr, 2)
            vSwap = arr(i, k)
            arr(i, k) = arr(j, k)
            arr(j, k) = vSwap
        Next
        
        i = i + 1 '左側は1つ右からスタート
        j = j - 1 '右側は1つ左からスタート
    Loop
    
    If iLeft < i - 1 Then
        Call SortArray(arr, targetCol, ascFlag, iLeft, i - 1)
    End If
    
    If j + 1 < iRight Then
        Call SortArray(arr, targetCol, ascFlag, j + 1, iRight)
    End If
    
End Sub

ソースに一部不要な箇所がありましたので、訂正します。
Function Scoringのみ訂正です。
 

Function Scoring(allRange As Range, targetRange As Range, priorityRange As Range)
    'allRange：科目名と点数記載された範囲を選択してください。（合計列などは不要です）
    'targetRange：順位を求めたい行範囲を選択してください。範囲は「allRange」と同じ列です。
    'priorityRange：科目の優先順位を記載した範囲を選択してください。記載順に上から優先されます。
    
    Dim rowRng As Range
    Dim rng As Range
    Dim n As Integer, i As Integer
    Dim targetRow As Integer: targetRow = targetRange.Row - allRange.Row + 1
    Dim allRangeArr As Variant
    allRangeArr = allRange.Value2
    ReDim Preserve allRangeArr(1 To UBound(allRangeArr, 1), 1 To UBound(allRangeArr, 2) + 1)
    Dim sumCol As Integer: sumCol = UBound(allRangeArr, 2)
    
    '各行の合計を求める
    For i = LBound(allRangeArr, 1) + 1 To UBound(allRangeArr, 1)
        For n = LBound(allRangeArr, 2) To UBound(allRangeArr, 2) - 1
            allRangeArr(i, sumCol) = allRangeArr(i, sumCol) + allRangeArr(i, n)
        Next n
    Next i
    
    '対象行の合計と同点の行が存在するか確認する
    Dim sameScoreCheck As Variant
    sameScoreCheck = UBound(Split(Join(WorksheetFunction.Index(WorksheetFunction.Transpose(allRangeArr), sumCol), ","), allRangeArr(targetRow, sumCol)))
    
    If sameScoreCheck = 1 Then
        Scoring = GetRank(allRangeArr, sumCol, allRangeArr(targetRow, sumCol))
    Else
        Dim factor As Double
        For n = LBound(allRangeArr, 2) To UBound(allRangeArr, 2) - 1
            For i = LBound(allRangeArr, 1) To UBound(allRangeArr, 1)
                If i = 1 Then
                    factor = 0.1 ^ (WorksheetFunction.Match(allRangeArr(i, n), priorityRange, 0) + 2) '係数を作成
                Else
                    allRangeArr(i, sumCol) = allRangeArr(i, sumCol) + allRangeArr(i, n) * factor '合計に科目点＊係数を足す
                End If
            Next i
        Next n
        Scoring = GetRank(allRangeArr, sumCol, allRangeArr(targetRow, sumCol))
    End If
End Function

質問者さんからマクロ記録の結果が出てくるのを待っていましたが、
こちらも忘れてしまいそうなので、とりあえず、書いておいたコードを挙げておきます。
 
<<シートレイアウト>>

      A列     B       C       D       E       F       G       H       I列      J
1行   番号    国語    社会    数学    理科    合計    順位            合計    
2     1       59      64      55      44      222     3               国語    
3     2       59      65      50      48      222     2               社会    
4     3       57      63      53      47      220     5               数学    
5     4       57      63      53      48      221     4               理科    
6     5       57      63      52      48      220     6                       
7     6       60      64      53      46      223     1  

Sub test()
    Dim rng     As Range
    Dim sort順  As Range
    Dim k       As Long
    Dim j       As Long
    
    Set rng = Range("A1")   '表の左上端のセル   '■要調整(A1を修正）
    Set sort順 = Range("I1").CurrentRegion      '■要調整(I1を修正）
    Set rng = rng.CurrentRegion
    
    '指定された項目順を優先順としてソートを実行
    With ActiveSheet.Sort
        .SortFields.Clear
        For k = 1 To sort順.Count
            j = Application.Match(sort順.Cells(k).Value, rng.Rows(1), 0)
            .SortFields.Add2 Key:=rng.Cells(1, j), _
             SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        Next
        .SetRange rng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    '順位の書き込み
    Dim targetRange As Range
    Set targetRange = rng.Columns(rng.Columns.Count)
    Set targetRange = Intersect(targetRange, targetRange.Offset(1))
    targetRange(1) = 1
    targetRange.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=targetRange.Count, Trend:=False
    
    '元の番号順に戻す
    rng.Sort key1:=rng(1), order1:=xlAscending, Header:=xlYes
End Sub