|
おはようございます。
>同点の場合が有るので、人名rも入るのかな
とHirofumiさんがおっしゃっていますね!!
これを考慮すると・・・。
> B C D E F G
>7 人名a 23 人名a 111
>8 人名b 12 人名b 222
>9 人名c 14 人名c 121
>10 人名d 21 人名d 212
>11 人名e 22 人名e 311
>12 人名f 111 人名f 123
>13 人名g 222 人名g 321
>14 人名h 333 人名h 221
>15 人名i 444 人名i 234
>16 人名j 555 人名j 432
>17 人名k 666 人名k 101
>18 人名l 777 人名l 555
>19 人名m 888 人名m 666
>20 人名n 999 人名n 777
>21 人名o 129 人名o 120
>22 人名p 138 人名p 200
>23 人名q 397 人名q 146
>24 人名r 222 人名r 450
これをB:C列をC列、F:G列をG列で降順に並べ替えると
'=====================================================
B C D E F G
7 人名n 999 人名n 777
8 人名m 888 人名m 666
9 人名l 777 人名l 555
10 人名k 666 人名r 450
11 人名j 555 人名j 432
12 人名i 444 人名g 321
13 人名q 397 人名e 311
14 人名h 333 人名i 234
15 人名r 222 人名b 222
16 人名g 222 人名h 221
17 人名p 138 人名d 212
18 人名o 129 人名p 200
19 人名f 111 人名q 146
20 人名a 23 人名f 123
21 人名e 22 人名c 121
22 人名d 21 人名o 120
23 人名c 14 人名a 111
24 人名b 12 人名k 101
となります(ここまでは出来るのですよね?)
このデータに対して、
標準モジュールに
'==================================================================
Sub main()
Dim rng1 As Range
Dim rng2 As Range
Dim rw1 As Long
Dim rw2 As Long
Const 調査順位 As Long = 9
On Error Resume Next
With Range("c7", Cells(Rows.Count, 3).End(xlUp))
rw1 = Evaluate("max(if(" & .Address & "=large(" _
& .Address & "," & 調査順位 & _
"),row(" & .Address & ")))")
If Err.Number <> 0 Then rw1 = .Row + .Rows.Count - 1
End With
Err.Clear
With Range("g7", Cells(Rows.Count, 7).End(xlUp))
rw2 = Evaluate("max(if(" & .Address & "=large(" _
& .Address & "," & 調査順位 & _
"),row(" & .Address & ")))")
If Err.Number <> 0 Then rw2 = .Row + .Rows.Count - 1
End With
Range("b:b,f:f").FormatConditions.Delete
Set rng1 = Range("b7:b" & rw1)
Set rng2 = Range("f7:f" & rw2)
With rng1
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=countif(" & rng2.Address(, , xlR1C1) & ",rc)"
.FormatConditions(1).Interior.ColorIndex = 6
End With
With rng2
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=countif(" & rng1.Address(, , xlR1C1) & ",rc)"
.FormatConditions(1).Interior.ColorIndex = 6
End With
On Error GoTo 0
End Sub
人名rまで塗りつぶし対象になります。
これも試してみてください。
|
|