Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : 指定なし)
countifsを使った順位
投稿日時: 22/02/19 14:47:10
投稿者: cocoa11
メールを送信

次のような同店がる成績の場合の順位付けとして、
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


 
人数は講座よって毎回変わります。
g列に入れる数式は次のようなると思うのですが、
RANK(f3,$f$3:$f$)+COUNTIF(f3:$f$,f3)-1
VBA初心者でよくわかりません。
 
 

回答
投稿日時: 22/02/19 15:54:17
投稿者: simple

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

回答
投稿日時: 22/02/19 20:10:05
投稿者: simple

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

回答
投稿日時: 22/02/20 10:01:20
投稿者: 半平太

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

投稿日時: 22/02/20 10:41:39
投稿者: cocoa11
メールを送信

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

ご指摘ありがとうございます。
テストの成績なので、ご指摘の通り100までの整数になります。科目数は増えますので、合計は1000店程度になります。

投稿日時: 22/02/20 10:42:56
投稿者: cocoa11
メールを送信

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

 
ご指摘ありがとうござます。
×を使ったものを一度考えてみます。

回答
投稿日時: 22/02/20 11:29:33
投稿者: 半平太

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

回答
投稿日時: 22/02/21 10:18:01
投稿者: んなっと

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"))

回答
投稿日時: 22/02/21 11:11:03
投稿者: んなっと

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

回答
投稿日時: 22/02/21 15:18:44
投稿者: 半平太

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

回答
投稿日時: 22/02/22 10:50:18
投稿者: R-

<準備>
@以下のコードを標準モジュールにコピペしてください。
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
引用:

回答
投稿日時: 22/02/22 11:17:22
投稿者: R-

ソースに一部不要な箇所がありましたので、訂正します。
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

回答
投稿日時: 22/02/22 15:55:03
投稿者: simple

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

      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  

 
■注意事項
(1)
・「得点表」の最初の位置("A1")と
・優先順位を書いたセル範囲(「優先順位項目表」)の最初の位置("I1")
をコードで指定していますが、これを実態に合わせて修正する必要があります。
 
(2)
また、「得点表」と「優先順位項目表」は、空白行、空白列で分離されている必要があります。
 
■参考コード
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

・んなっとさんの計算式での方法が、今のやりかたの延長線上では使いやすいかもしれませんね。
 
・なお、コードでセル位置をコーントロールするのは慣れないと億劫かもしれません。
(Application.InputBox(Type:=8)でユーザーに指定させることも考えられますね。)
 
・COUNTIFSを使うって、この話にどう関係してくるんですか?
>worksheetfaunction のrank関数を使うよりcountifsを使うとありますが
って、どこの話ですか、支障なければ紹介願いたい。
学年別の順位に加えて、各クラスの順位とかそういう話なんですか?

トピックに返信