Excel VBA 同順位の順位補正について

Question

Excel VBA 同順位の順位補正について

A1 100 B1とB2を連結
A2 150 B1＝A1+A2 250
A3 180 B3とB4を連結

A4 70 B3=B3+B4 250
A5 100 B5とB6を連結
A6 200 B5＝A5+A6 300

このままだと、

B1 順位2
B2 順位3
B3 順位1

判定条件 

B列の値が大きい順にC列に順位を記載する
ただし、B列に同順位があるときは、A列を参照して、その中で、一番大きい値を持っているA列（この場合は、A3）の隣セルの順位を上げる


最終的な表示は


B1 順位3
B2 順位2
B3 順位1

上記のようにしたいです。

私が、思いつくのは、For Eachで同じものを求めて、
C列に重複と表示して
その重複のセルを基点として、offsetで指定する

こんな感じでコードを記載しているのですが、どうもうまくできません。

お手数ですが、どのようなコードになるのが、こ教示していただけないでしょうか。

お願いします。

tatsu99 · Accepted Answer

No2です。以下のマクロを標準モジュールに登録してください。

Option Explicit
Public Sub 順位付()
    Dim maxrow As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim max_val As Long
    Dim max_row As Long
    Dim wval As Long
    Dim rank  As Long
    
    maxrow = Cells(Rows.Count, 1).End(xlUp).Row    'sheetの最大行取得
    If (maxrow Mod 2) <> 0 Then
        MsgBox ("A列行数不正")
        Exit Sub
    End If
    Range("C1:C" & maxrow).Value = ""
    rank = 1
    For row1 = 1 To maxrow Step 2
        max_val = -1
        max_row = 0
        For row2 = 1 To maxrow Step 2
            If Cells(row2, "C").Value = "" Then
                wval = Cells(row2, "B").Value
                If wval = max_val Then
                    If Maxval(row2) > Maxval(max_row) Then
                        max_val = wval
                        max_row = row2
                    End If
                ElseIf wval > max_val Then
                    max_val = wval
                    max_row = row2
                End If
            End If
        Next
        Cells(max_row, "C").Value = rank
        rank = rank + 1
    Next
    MsgBox ("完了")
End Sub

Private Function Maxval(ByVal wrow As Long)
    Maxval = Cells(wrow, "A").Value
    If Cells(wrow + 1, "A").Value > Maxval Then
        Maxval = Cells(wrow + 1, "A").Value
    End If
End Function

tom04 · Answer

こんばんは！

お望みのVBAではなく、関数でやってみました。
↓の画像のように作業用の列を設けています。

作業列E2セルに
=IF(B2="","",RANK(B2,B:B,2)*10^10+MAX(OFFSET(B2,0,-1,2)))

という数式を入れフィルハンドルで下へコピーしておきます。

C2セルに
=IF(E2="","",RANK(E2,E:E))

という数式を入れフィルハンドルで下へコピーすると
画像のような感じになります。m(_ _)m

tatsu99 · Answer

実際はB列の結合セルは３つだけではなくて、もっと多いのでしょうか。
例えば、添付画像のように。赤線が提示された部分です。青線が例として追加した部分です。
レイアウトは添付の画像であってますか？

Excel VBA 同順位の順位補正について

こんばんは！

実際はB列の結合セルは３つだけではなくて、もっと多いのでしょうか。

No2です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング