[[20080808222458]]　『セル位置は変えずに同じ値に色を付けるには』（甘太郎）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『セル位置は変えずに同じ値に色を付けるには』（甘太郎）

 過去ログからの質問で申し訳ありませんが、
 以下の(元データ)をNo毎にＣからＧまで点数が入力されたら一行ずつ点数を降順に並び替えて、
 最高点と最小点を省いた三つの点数で合計を出し、
 更にこの合計点を点数の高い順に降順に並び替えて
 最後にその合計点の中で同点があれば隣のセルに表示させて(実行後)の形となる様にしました。
 質問は、この最後の処理である「隣のセルに表示させる」を
 「合計点のセルＰで同点があればそれをグループ毎に色分けする(例えば赤、青、赤、青)」としたいのです。
 この部分のコードはご教授頂いたものが下記の様になっています。
 どこを変更すれば希望する形になるのかがイマイチよく分かりません。
 どうぞ宜しくお願いいたします。
 (尚、この元データは実際にはNo1〜50位まであります)
Sub TEST()
    Range("R7").Select
    Application.Width = 750.75
    Application.Height = 381.75
    Columns("P:P").Select
    Range("I1:P40").Sort key1:=Range("P1"), order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    Range("L14").Select
    With Range("Q1:Q41").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
    Dim myR As Range
    Set myR = Range("P1", Range("P" & Rows.Count).End(xlUp))
    With myR.Offset(, 1)
         .Formula = "=IF(COUNTIF(" & myR.Address & ",P1)>1,P1,"""")"
         .Value = .Value
    Range("Q1") = "同点"
End With
End Sub

(元データ)

    [A] [B] [C] [D] [E] [F] [G] 	
[1]  No 氏名点数点数点数点数点数　		
[2]  1  AAA 7.1 7.5 7.7 7.8 7.9　		
[3]  2  BBB 7.1 7.6 7.8 7.8 7.9		
[4]  3  CCC 7.4 7.6 7.8 7.8 7.9	                               	
[5]  4  DDD 7.1 7.8 7.9 8.0 8.0	                               	
[6]  5  EEE 7.2 7.2 7.6 7.9 8.0	                               	
[7]  6  FFF 7.1 7.3 7.6 7.8 7.9		
[8]  7  GGG 7.1 7.1 7.8 7.9 8.0	                               	
[9]  8  HHH 7.2 7.4 7.5 7.9 7.9

(実行後)

    [I]  [J]  [K]  [L]  [M]  [N]  [O]  [P]  [Q]  	
[1]  No 氏名 最高点点数 点数 点数最小点合計 同点		
[2]　4   DDD  8.0	 8.0  7.9	  7.8  7.1 23.7 
[3]  2	BBB  7.9	 7.8  7.8  7.6  7.1 23.2  23.2
[6]  3	CCC　7.9　7.8　7.8　7.6  7.4 23.2  23.2　　　　　　　　　 	
[4]  1	AAA  7.9  7.8  7.7  7.5  7.1 23.0                     	
[5]  8	HHH  7.9  7.9  7.5  7.4  7.2 22.8  22.8                  	
[7]  7	GGG  8.0  7.9  7.8  7.1  7.1 22.8  22.8	
[9]  5	EEE  8.0  7.9  7.6  7.2  7.2 22.7  22.7                   	
[8]  6   FFF  7.9  7.8  7.6  7.3  7.1 22.7  22.7

 [Excel2002] 
 [WindowsXP]

---

 >Dim myR As Range
 >  Set myR = Range("P1", Range("P" & Rows.Count).End(xlUp))
 >    With myR.Offset(, 1)
 >         .Formula = "=IF(COUNTIF(" & myR.Address & ",P1)>1,P1,"""")"
 >         .Value = .Value
 >         Range("Q1") = "同点"
 >   End With

    ↑
 　ここの部分をこんな風にすればいいのではないですか？（色づけ範囲の詳細が分かりませんの、細部はそちらでアジャストしてください）
 　　　　　　　　↓
  Dim myR As Range
  Dim Cel As Range
     Set myR = Range("P2", Range("P" & Rows.Count).End(xlUp))

     With myR.Offset(, 1)
         .Formula = "=IF(COUNTIF(" & myR.Address & ",P2)>1,P2,"""")"
         .Value = .Value
     　　Range("Q1") = "同点"
     End With    

 　　For Each Cel In myR
      　　With Cel.Offset(, -7).Resize(, 8).Interior
          　If Cel.Value <> Cel.Offset(-1).Value Then
            　  If Cel.Offset(-1).Interior.ColorIndex = 3 Then
              　    .ColorIndex = 5
            　  Else
 　　　　　　　　　 .ColorIndex = 3
             　 End If
            Else
             　 .ColorIndex = Cel.Offset(-1).Interior.ColorIndex
          　End If
      　End With
 　　Next

  （半平太）

---

半平太さん、ありがとうございます。
教えて頂いたコードを実行した結果、少し希望した形と違っていたので再度ご教授頂ければありがたいです。
「Ｑ列へ表示させる」という部分はその箇所のコードを削除する事(下記コード)で希望した形となりました。

Sub TEST()
Range("R7").Select

    Application.Width = 750.75
    Application.Height = 381.75
    Columns("P:P").Select
    Range("I1:P40").Sort key1:=Range("P1"), order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    Range("L14").Select
    Dim myR As Range
    Dim Cel As Range
     Set myR = Range("P2", Range("P" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel.Offset(, -7).Resize(, 8).Interior
            If Cel.Value <> Cel.Offset(-1).Value Then
                If Cel.Offset(-1).Interior.ColorIndex = 3 Then
                    .ColorIndex = 5
                Else
                    .ColorIndex = 3
                End If
            Else
                .ColorIndex = Cel.Offset(-1).Interior.ColorIndex
            End If
        End With
     Next
    End Sub

あとは、色分けの結果が、セルの上から順番に交互に赤、青と色分けされましたが、これを「Ｐ列の値が上下で同じ値だった場合のみ交互に赤、青と色分けしたい」という風にしたいのです。(下記)
つまり、同じ値でないものは色付けしないという事です。
尚、この上下同じ値という部分ですが、必ずしも上下二つのみが同じとは限らず、上下に三つ、または四つ同じという場合があります。
また、色分けの範囲ですが、Ｐ列のみとしたいのですが。
色々とすみませんが、宜しくお願いいたします。

[P]
合計
23.7 色なし
23.2 赤
23.2 赤　
23.0 色なし
22.8 青
22.8 青
22.7 赤
22.7 赤

(甘太郎)

---

 　こんなことですか？

    Dim myR As Range
    Dim Cel As Range
    Dim clrIdx As Integer

     Columns("P:P").Interior.ColorIndex = xlNone

     Set myR = Range("P2", Range("P" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel
              If .Value = .Offset(-1) Then
                    .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
              ElseIf .Value = .Offset(1) Then
                    clrIdx = IIf(clrIdx = 3, 5, 3)
                     .Interior.ColorIndex = clrIdx
             End If
          End With
     Next

 （半平太）

---

半平太さん、ありがとうございます。
早速、提示して頂いたコードを実行してみました。
下記の様な結果となり、２２．８の点数に色付けがされませんでした。
これを--->の様にしたいのですが。

     [P]    	
[1]  合計 		
[2]　23.7 
[3]  23.2 (赤)
[6]  23.2 (赤)　　　　　　　　　 	
[4]  23.0                     	
[5]  22.8 ---------> (青)               	
[7]  22.8	 ---------> (青)
[9]  22.7 (青)-----> (赤)                  	
[8]  22.7 (青)-----> (赤)

(甘太郎)

---

 それは小数誤差のセイだと思います。

 人の目には同じ22.8に見えても、実体は同点ではないと判定されています。

 <実験> 真下のセルと同値か Match関数 を使って検証すると分かります。
 　↓
  行   _P__  _Q__   
   1   合計                         
   2   23.7  #N/A =MATCH(P2,P3,0)   
   3   23.2     1 =MATCH(P3,P4,0)   
   4   23.2  #N/A =MATCH(P4,P5,0)   
   5     23  #N/A =MATCH(P5,P6,0)   
   6   22.8  #N/A =MATCH(P6,P7,0)   ←P6とP7は同じではないとの判定です。
   7   22.8  #N/A =MATCH(P7,P8,0)   
   8   22.7     1 =MATCH(P8,P9,0)   
   9   22.7  #N/A =MATCH(P9,P10,0)  

  ついては、合計値に小数誤差対策をして頂く必要があると思います。

 どのように合計を算出しているのかお聞きしておりませんが、例えば

 　 P2セル =ROUND(SUM(L2:N2),1)

 のような対策を施す必要があります。

  （半平太）

---

 少し疑問なのですが・・・・
 ＞２２．８の点数に色付けがされませんでした。
 この時のQ列（COUNTIF関数の結果）では
 「同点」となっているのですか？

 でしたら、Q列のセルで確認するのはどうでしょう。

 '------
    Dim myRng As Range, myCel As Range, myCol As Integer
    Set myRng = Range("Q2", Range("Q" & Rows.Count).End(xlUp))
    Columns("P:P").Interior.ColorIndex = xlNone
    For Each myCel In myRng
        With myCel
            If .Value <> "" Then
                If .Value <> .Offset(-1).Value Then
                    myCol = IIf(myCol = 3, 5, 3)
                End If
                .Offset(, -1).Interior.ColorIndex = myCol
            End If
        End With
    Next
 '------

 おそらく、P列は数式が入っていると思います。
 これをQ列と同じように　.Value = .Value
 とすると、半平太さんが書いて居られるコードでも
 正しく色づけがされるのではないでしょうか？

 (HANA) 

---

 小数誤差って、非常に小さな値を扱った時にのみ
 発生する物かと思ってましたが
 小数第１位までの計算でも、発生しているのですね。

 ・・・でも、COUNTIF関数ではＯＫなのが不思議。
 =MATCH(P6,P7,0)    →　#N/A
 =P6=P7             →　TRUE
 =COUNTIF(P6:P7,P6) →  2
 って・・・。

 しかも、値貼り付けしたら
 =MATCH(P6,P7,0)    →　1
 に成るんですよね。。。

 (HANA)

---

 >=P6=P7                
 　  ↑　　　　　　　　　=P6-P7=0
 　　｜                     ↑
 これはTrueになりますが、これはFasleになります。

 行   _K_  _L_  _M_  _N_  _O_  _P__  __Q__  
  6   7.9  7.9  7.5  7.4  7.2  22.8  TRUE    Q6セル =P6=P7    
  7     8  7.9  7.8  7.1  7.1  22.8  FALSE   Q7セル =P6-P7=0  

 マイクロソフトの訳が分からない独自仕様で、私は解明する気が起きません。
 エクセルで、計算が絡む小数の異同大小を判定するのは危なっかしい事なんだな、と認識するのみです。

 （半平太）

---

半平太さん、HANAさん、
２２．８に色付けがされない件は、半平太さんの「合計値に少数誤差対策をする」やり方で解決しました。ありがとうございました。
この後の処理として、Ｐ列で同点となったグループの順位付けをしたいのです。
順位付けは以下のやり方です。
１．Ｐ列の同点に対してＮ列の点数３を加算する。
２．その結果、Ｑ列で差が出れば終わり。もしそれでも同点の場合、Ｌ列の点数１を加算する。
３．同じ様にＲ列で差が出れば終わり。もし差がつかなければＫ列の最高点とＯ列の最小点を加算する。
このやり方を実行した結果とコードが下記です。
問題はＰ列の合計の所で同点でないものまでがそれ以降も上記のやり方で加算されてしまう事です。
つまり、()の部分は不要という事です。同じ様に、同点のグループに対して上記のやり方で加算して差が付いたにも拘わらずその後も加算されてしまう点です。
これを一番下に示した(希望する結果)の形にしたいのですが、コードのどこを訂正してよいかわかりません。ご教授頂ければ幸いです。宜しくお願いします。

    [I]  [J]  [K]  [L]  [M]  [N]   [O]   [P]     [Q]  	    [R]          [S]
[1]  No 氏名 最高点点数1点数2点数3最小点 合計 同点その１同点その２  同点その３	
[2]　4   DDD  8.0	 8.0  7.9	  7.8  7.1   23.7   (31.5)    (39.5)       (54.6) 
[3]  2　 BBB  7.9	 7.8  7.8  7.6  7.1   23.2    30.8      38.6         53.6
[6]  3　 CCC　7.9　7.8　7.8　7.6  7.4   23.2    30.8　　  38.6         53.9　　　　　　　 	
[4]  1　 AAA  7.9  7.8  7.7  7.5  7.1   23.0   (30.5)    (38.3)       (53.3)           	
[5]  8　 HHH  7.9  7.9  7.5  7.4  7.2   22.8    29.9     (37.8)       (52.9)            	
[7]  7　 GGG  8.0  7.9  7.8  7.1  7.1   22.8    30.2	  (38.1)       (53.2)
[9]  5　 EEE  8.0  7.9  7.6  7.2  7.2   22.7    29.9     (37.8)       (53.0)              	
[8]  6   FFF  7.9  7.8  7.6  7.3  7.1   22.7    30.0     (37.8)       (52.8)

Sub TEST1()
With Range("Q1:Q41").Borders

  .Weight = xlThin
  .ColorIndex = 1
End With
    Dim i As Long
    For i = 2 To 41 '行数 2行目〜41行目
        If Range("P" & i).Value <> "" Then
            Range("Q" & i).Value = _
            Range("P" & i).Value + Range("N" & i).Value
        End If
    Next
    Range("Q1") = "同点その１"
    Dim myR As Range
    Dim Cel As Range
    Dim clrIdx As Integer

     Columns("Q:Q").Interior.ColorIndex = xlNone

     Set myR = Range("Q2", Range("Q" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel
              If .Value = .Offset(-1) Then
                    .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
              ElseIf .Value = .Offset(1) Then
                    clrIdx = IIf(clrIdx = 3, 5, 3)
                     .Interior.ColorIndex = clrIdx
             End If
          End With
     Next
End Sub
Sub TEST2()
With Range("R1:R41").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
    Dim i As Long
    For i = 2 To 41 '行数 2行目〜41行目
        If Range("Q" & i).Value <> "" Then
            Range("R" & i).Value = _
            Range("Q" & i).Value + Range("L" & i).Value
        End If
    Next
    Range("R1") = "同点その２"
    Dim myR As Range
    Dim Cel As Range
    Dim clrIdx As Integer

     Columns("R:R").Interior.ColorIndex = xlNone

     Set myR = Range("R2", Range("R" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel
              If .Value = .Offset(-1) Then
                    .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
              ElseIf .Value = .Offset(1) Then
                    clrIdx = IIf(clrIdx = 3, 5, 3)
                     .Interior.ColorIndex = clrIdx
             End If
          End With
     Next
    End Sub
Sub TEST3()
With Range("S1:S41").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
    Dim i As Long
    For i = 2 To 41 '行数 2行目〜41行目
        If Range("R" & i).Value <> "" Then
            Range("S" & i).Value = _
            Range("R" & i).Value + Range("K" & i).Value + Range("O" & i).Value
    End If
    Next
    Range("S1") = "同点その３"
    Dim myR As Range
    Dim Cel As Range
    Dim clrIdx As Integer

     Columns("S:S").Interior.ColorIndex = xlNone

     Set myR = Range("S2", Range("S" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel
              If .Value = .Offset(-1) Then
                    .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
              ElseIf .Value = .Offset(1) Then
                    clrIdx = IIf(clrIdx = 3, 5, 3)
                     .Interior.ColorIndex = clrIdx
             End If
          End With
     Next
    End Sub

(希望する結果)

    [I]  [J]  [K]  [L]  [M]  [N]   [O]   [P]     [Q]  	    [R]          [S]
[1]  No 氏名 最高点点数1点数2点数3最小点 合計 同点その１同点その２  同点その３	
[2]　4   DDD  8.0	 8.0  7.9	  7.8  7.1   23.7    
[3]  2	BBB  7.9	 7.8  7.8  7.6  7.1   23.2    30.8      38.6         53.6
[6]  3	CCC　7.9　7.8　7.8　7.6  7.4   23.2    30.8　　  38.6         53.9　　　　　　　 	
[4]  1	AAA  7.9  7.8  7.7  7.5  7.1   23.0              	
[5]  8	HHH  7.9  7.9  7.5  7.4  7.2   22.8    29.9                 	
[7]  7	GGG  8.0  7.9  7.8  7.1  7.1   22.8    30.2	  
[9]  5	EEE  8.0  7.9  7.6  7.2  7.2   22.7    29.9                   	
[8]  6   FFF  7.9  7.8  7.6  7.3  7.1   22.7    30.0     

(甘太郎)

---

 つまり同点決勝は３回行うちゅう事でんな？
 こんな塩梅でどうでっか？
 あ、それからHHHからしたのQ列データはちがうようにおもいますが。。。
 P列＋N列ならHHHは30.2になるはず。 　　　　　
  　　　　　　（弥太郎）
 '----------------------------
 Sub TEST5()
    Dim i As Long, x(), myR As Range, Cel As Range, clrIdx As Long, ary
    Dim u As Integer, j As Integer, idx
    With Range("Q1:Q41").Borders
      .Weight = xlThin
      .ColorIndex = 1
    End With
    ary = Array("P", "Q", "R", "S")
    idx = Array(-2, -5, -7)
    For i = 2 To 41
        ReDim Preserve x(i - 2)
        x(i - 2) = Range("P" & i).Address(0, 0)
    Next i
    For u = 1 To 3
        With Range(ary(u) & "1:" & ary(u) & "41").Borders
            .Weight = xlThin
            .ColorIndex = 1
        End With
        j = 0
        clrIdx = xlNone
        Set myR = Range(Join(x, ","))
        For Each Cel In myR
            If Cel <> "" And Application.CountIf(Range(ary(u - 1) & ":" & ary(u - 1)), Cel) > 1 Then
                Cel.Offset(, 1).Value = Cel + Cel.Offset(, -2).Value
                Cel.Offset(, 1).Value = Cel + Cel.Offset(, idx(u - 1)) + IIf(u = 3, Cel.Offset(, -3), 0)

            End If
        Next
        Range(ary(u) & 1) = "同点その" & StrConv(u, vbWide)
        Columns(u + 16).Interior.ColorIndex = xlNone
        Set myR = Range(Join(x, ",")).Offset(, 1)
         For Each Cel In myR
              With Cel
                  If .Value <> "" Then
                     If .Value = .Offset(-1) And .Offset(-1, -1) = .Offset(, -1) Then
                           .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
                           ReDim Preserve x(j)
                           x(j) = Cel.Address(0, 0)
                           j = j + 1
                     ElseIf .Value = .Offset(1) And .Offset(, -1).Value = .Offset(1, -1).Value Then
                           clrIdx = IIf(clrIdx = 3, 5, 3)
                            .Interior.ColorIndex = clrIdx
                            ReDim Preserve x(j)
                            x(j) = Cel.Address(0, 0)
                            j = j + 1
                    End If
                End If
              End With
         Next
         If j = 0 Then Exit For
    Next u
 End Sub

---

弥太郎さん、
すみません、転記ミスでＨとＧのデータが逆になっていました。正しくは以下のとおりです。

(誤)
HHH 7.9 7.9 7.5 7.4 7.2 22.8 29.9
GGG 8.0 7.9 7.8 7.1 7.1 22.8　　30.2

(正)　　　
HHH 8.0 7.9 7.8 7.1 7.1 22.8 29.9
GGG 7.9 7.9 7.5 7.4 7.2 22.8　　30.2

ご教授頂いたコードを試したところ間違いなく希望した結果が得られました。
しかし、試しにＥとＦの値を以下の様に変えて実行してみたところ、Ｈ以下Ｆまでが同点となりましたが、Ｑ列で同点と認識されず、処理がそこで終わりました。
このコードでは上下の隣り合わせの同点の値しか認識しないのでしょうか？
また、以下の様な離れたところにある同じ値を認識させるコードにするにはどの様にすればいいのでしょうか？

EEE 8.0 7.9 7.6 7.2 7.2 22.7 29.9
FFF 7.9 7.8 7.6 7.3 7.1 22.7 30.0

(結果)

    [I]  [J]  [K]  [L]  [M]  [N]   [O]   [P]     [Q]  	    [R]          [S]
[1]  No 氏名 最高点点数1点数2点数3最小点 合計 同点その１同点その２  同点その３	
[2]　4   DDD  8.0	 8.0  7.9	  7.8  7.1   23.7    
[3]  2	BBB  7.9	 7.8  7.8  7.6  7.1   23.2    30.8      38.6         53.6
[6]  3	CCC　7.9　7.8　7.8　7.6  7.4   23.2    30.8　　  38.6         53.9　　　　　　　 	
[4]  1	AAA  7.9  7.8  7.7  7.5  7.1   23.0              	
[5]  8	HHH  8.0  7.9  7.6  7.3  7.2   22.8    30.1                 	
[7]  7	GGG  7.9  7.8  7.6  7.4  7.1   22.8    30.2 <---	  
[9]  5	EEE  8.0  7.9  7.8  7.1  7.1   22.8    29.9                   	
[8]  6   FFF  7.9  7.9  7.5  7.4  7.2   22.8    30.2 <---

(甘太郎)

---

 まぁなんとイヤラシイデータが存在しまんねんなぁ。＾＾
 検証不足かもしれまへんが、これでどないなります？
 　　　　　（弥太郎）
 '--------------------
 Sub Iyarasi()
    Dim i As Long, x(), y(), myR As Range, Cel As Range, clrIdx As Long, ary
    Dim u As Integer, j As Integer, t As Integer, idx, z, b()
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    ary = Array("P", "Q", "R", "S")
    idx = Array(-2, -5, -7)
    For i = 2 To 41
        If Not IsEmpty(Range("P" & i)) And Application.CountIf(Range("P:P"), Range("P" & i)) > 1 Then
            ReDim Preserve x(j)
            x(j) = Range("P" & i).Address(0, 0)
            j = j + 1
        End If
    Next i
    For u = 1 To 3
        With Range(ary(u) & "1:" & ary(u) & "41").Borders
            .Weight = xlThin
            .ColorIndex = 1
        End With
        j = 0
        t = 0
        clrIdx = xlNone
        Set myR = Range(Join(x, ","))
        For Each Cel In myR
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, -2).Value
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, idx(u - 1)) + IIf(u = 3, Cel.Offset(, -3), 0)
            ReDim Preserve y(t)
            y(t) = Cel.Address(0, 0)
            data = Range("P" & Cel.Row).Value & "," & Cel.Offset(, 1).Value
            If Not dic.exists(data) Then
                dic(data) = Array(Cel.Offset(, 1).Address(0, 0))
            Else
                z = dic(data)
                ReDim Preserve z(UBound(z) + 1)
                z(UBound(z)) = Cel.Offset(, 1).Address(0, 0)
                dic(data) = z
            End If
            t = t + 1
        Next
        Range(ary(u) & 1) = "同点その" & StrConv(u, vbWide)
        Columns(u + 16).Interior.ColorIndex = xlNone
        Set myR = Range(Join(x, ",")).Offset(, 1)
        For Each Cel In myR
            With Cel
                If Not IsError(Application.Match(Cel.Offset(, -1).Address(0, 0), y, 0)) And _
                            Application.CountIf(Range(ary(u) & ":" & ary(u)), Cel) > 1 Then
                    data = Range("P" & Cel.Row) & "," & Cel.Value
                    If Not IsEmpty(dic(data)) Then
                        If dic.exists(data) And UBound(dic(data)) > 0 Then
                            For n = 0 To UBound(dic(data))
                                ReDim Preserve b(n)
                                b(n) = dic(data)(n)
                                ReDim Preserve x(j)
                                x(j) = b(n)
                                j = j + 1
                            Next
                            dic.Remove data
                            clrIdx = IIf(clrIdx = 3, 5, 3)
                            Range(Join(b, ",")).Interior.ColorIndex = clrIdx
                        End If
                    End If
                End If
              End With
         Next
         dic.removeall
         If j = 0 Then Exit For
    Next u
    Set dic = Nothing
 End Sub

---

弥太郎さん、
今度は同点が正しく認識されて希望どおりの結果が得られました、ありがとうございました。

こんな事も可能でしょうか？
下記の→の様に同点のグループ内での降順の並び替えです。
氏名ＢＣは得点差が付いたＳ列で並び替え、氏名ＨＧＥＦはＱ列で得点差が出るのでそこで並び替える、つまり得点差が出たら並び替えるという事です。
尚、これはＩ列からＳ列までの行単位で並び替えるという事です。宜しくお願いいたします。

    [I]  [J]  [K]  [L]  [M]  [N]   [O]   [P]   [Q]   [R]   [S]    
[1]  No 氏名 最高点点数1点数2点数3最小点 合計 同点１同点２同点３       
[2]　4   DDD  8.0	 8.0  7.9	  7.8  7.1   23.7                           
[3]  2	BBB  7.9	 7.8  7.8  7.6  7.1   23.2  30.8  38.6  53.6  ---> 53.9(Ｓ列で)
[6]  3	CCC　7.9　7.8　7.8　7.6  7.4   23.2  30.8　38.6  53.9　---> 53.6(Ｓ列で)
[4]  1	AAA  7.9  7.8  7.7  7.5  7.1   23.0              	        
[5]  8	HHH  8.0  7.9  7.6  7.3  7.2   22.8  30.1        ---> 30.2(Ｑ列で)             
[7]  7	GGG  7.9  7.8  7.6  7.4  7.1   22.8  30.2  38.0  ---> 30.2(Ｑ列で)             
[9]  5	EEE  8.0  7.9  7.8  7.1  7.1   22.8  29.9        ---> 30.1(Ｑ列で)            
[8]  6   FFF  7.9  7.9  7.5  7.4  7.2   22.8  30.2  38.1  ---> 29.9(Ｑ列で)            

(甘太郎)

---

 そんな事はマクロの記録で簡単にでける事とちゃいまっか？
   　　　　　　（弥太郎）

---

 それは、こちらの話では無いのですか？
[[20080727235645]]『セル位置を変えずに並べ替えるには？』（甘太郎) 

 最初から上記の様なご説明をしておられたら
 その様なコメントがもらえたのではないかと思います。
（コメントのもらいっぱなしってのもいかがな物かと思いますが。）

 ちなみに
 ＞氏名ＨＧＥＦはＱ列で得点差が出るのでそこで並び替える
 Q列で並べ替えた後、R列での並べ替えが必要に思いますが
 Q列の並べ替えだけでよいのでしょうか？

 以下を実行すると↓の結果に成ると思います。
	[P]	[Q]	[R]	[S]
[1]	合計	同点１	同点２	同点３
[2]	23.7			
[3]	23.2	30.8	38.6	53.9
[4]	23.2	30.8	38.6	53.6
[5]	23			
[6]	22.8	30.2	38.1	
[7]	22.8	30.2	38	
[8]	22.8	30.1		
[9]	22.8	29.9		
 成らなかったら・・・研究してみてください。
 ご希望と違う場合は、スルーしてください。

 '------
Sub 並べ替え()
Dim myAreas As Areas, myArea As Range, i As Integer
    For i = 1 To 3
        On Error Resume Next
        Set myAreas = Columns(i + 16).SpecialCells(2, 1).Areas
        On Error GoTo 0
        If myAreas Is Nothing Then Exit Sub
        For Each myArea In myAreas
            With Application.Intersect(Range("I:S"), myArea.EntireRow)
                .Sort key1:=.Cells(1, i + 8), order1:=xlDescending, Header:=xlNo
            End With
        Next
    Next
End Sub
 '------

 (HANA)

---

 え？、記録の段取りがわからんのんでっしゃろか？
 なにも難しく考える事は無いと思うんですが・・・。
 範囲を選択した状態でKey1をP列Key2をQ列Key3をR列でソート
 ２度目はKey1をP列Key2をS列でソート
 それをマクロの記録にとってコードに挿入すればOKデスヨ。
 　　　　　（弥太郎）

---

HANAさん、弥太郎さん、
ご教授頂いたコードで期待した結果が得られました。ありがとうございました。
HANAさんの仰るとおり、おんぶに抱っこばかりではいけませんね。名前のとおり甘っ太郎でした。
今度質問する時は、まずは自分でコードを作成し、それに対してコメントをもらう様にします。
また質問する事があるかも知れませんが、その時は宜しくお願いいたします。
色々とありがとうございました。
(甘太郎)

---

再質問ですみません。
合計値を以下の様に変えて、再度HANAさんから提示して頂いたコードで色分けの検証をしたところ、Ｑ列Ｒ列のところでの色分けがＰ列と異なってしまいました。
これは、Ｑ列で()の部分が同点とならなかったり、Ｒ列で()の所がブランクのために色分けのパターンが違ってしまったためと思われます。
希望としては、Ｐ列の所で同点となった時の配色パターンをＱ、Ｒ、Ｓ列にも適用したいのです。
(つまり、Ｐ列での同点の色をＱ，Ｒ，Ｓ列で同点の場合も同じ色にしたいという事です。)

	[P]	[Q]	[R]	[S]
[1]	合計	同点１	同点２	同点３
[2]	23.3	31.0	38.8	54.4
[3]	23.3	31.0	38.8	54.3
[4]	22.8    (30.4)   (	    )
[5]	22.8    (30.3)   (    )	
[6]	22.6	30.1	37.7	52.7
[7]	22.6	30.1	37.7	52.6
[8]	22.3	29.7	37.2	52.2
[9]	22.3	29.7     37.2     51.9

(甘太郎)

---

 甘太郎さんが、まだ見てくださっている様ですので
 今回のご質問に関する事ではないのですが
 弥太郎さんの
 ＞そんな事はマクロの記録で簡単にでける事とちゃいまっか？
 のお言葉、確かにその通りでしたので
 再度コードを作ってみました。
 こちらの方が簡単なコードなので良いと思います。

 Dim k1
    With Range("I:S")
        For Each k1 In Array("S2", "R2", "Q2", "P2")
            .Sort Key1:=Range(k1), Order1:=xlDescending, Header:=xlGuess
        Next
    End With

 (HANA)

---

HANAさん、弥太郎さん、ありがとうございました。
早速やってみたところ、同じ様な結果が得られました。

もうひとつの質問の方ですが、分かりにくい説明ですみません。
実行後の配色パターン(8,7,8)がＱ列、Ｒ列で()の様にしたいという事です。

	[P]	[Q]	[R]	[S]
[1]	合計	同点１	同点２	同点３
[2]	23.3(8)	31.0(8)	38.8(8)	54.4
[3]	23.3(8)	31.0(8)	38.8(8)	54.3
[4]	22.8(7)  30.4   
[5]	22.8(7)  30.3   	
[6]	22.6(8)	30.1(8)	37.7(8)	52.7
[7]	22.6(8)	30.1(8)	37.7(8)	52.6
[8]	22.3(7)	29.7(7)	37.2(7)	52.2
[9]	22.3(7)	29.7(7)  37.2(7)  51.9

(甘太郎)

---

 それがしのマクロにはP列に色付けされるコードが入って無い筈ですが。。。
 違うマクロの事でっしゃろか？
 まぁ、とりあえずP列が色付けされとる状態で

      dic.Remove data
      clrIdx = IIf(clrIdx = 3, 5, 3)
      Range(Join(b, ",")).Interior.ColorIndex = clrIdx
 の３行を
      dic.Remove data
      Range(Join(b, ",")).Interior.ColorIndex = Range(b(n - 1)) _
                                    .Offset(, -1).Interior.ColorIndex

 に差し替えてみてくらい。
 　　　　　（弥太郎） 
　

---

弥太郎さん、
ご教授頂いたコードで希望した色分けの結果が得られたので、お礼の返信をしたつもりでいたのですが、何かの手違いでコメントが載らなかったみたいです。すみませんでした。

質問と言うか不明な点があり、再質問させて頂きました。
元データを色々変えて検証していたところ、下記の様に実行後のＰ列の６行目〜９行目の並び替えがおかしくなるケースが発生しました。
下記に示したコードで実行したのですが、このコードでは全てのケースに対応できないのでしょうか？

(元データ)　　　　　　　　　　　　　　　　　　　　　(実行後のＰ列以降)

    [I]  [J]  [K]  [L]  [M]  [N]   [O]             [P]   [Q]   [R]   [S]    
[1]  No 氏名 点数1点数2点数3点数4点数5            合計 同点１同点２同点３       
[2]　1   AAA  7.1	 7.5  7.7	  7.8  7.9             23.7                           
[3]  2	BBB  7.1	 7.6  7.8  7.8  7.9             23.2  30.8  38.6  53.9  
[4]  3	CCC　7.4　7.6　7.8　7.8  7.9             23.2  30.8　38.6  53.6　
[5]  4	DDD  7.1  7.8  7.9  8.0  8.0             23.0              	        
[6]  5	EEE  7.2  7.2  7.6  7.8  8.0             22.7  30.1  30.1                   
[7]  6	FFF  7.1  7.3  7.6  7.7  7.9             22.6  29.9  29.9               
[8]  7	GGG  7.1  7.1  7.8  7.8  8.0             22.7  29.8  29.8                  
[9]  8   HHH  7.2  7.4  7.5  7.8  7.9             22.6  29.8  29.8     

(コード)
Sub Macro1()
With Range("I1:P2").Borders

  .Weight = xlThin
  .ColorIndex = 1
End With
With Range("I1:P1").Font
  .Name = "MS P ゴシック"
  .Bold = True
  .ColorIndex = 1
  .FontStyle = "太字"
  .OutlineFont = True
  .Size = 12
Range("I1:P1").Select
With Selection.Interior
  .ColorIndex = 15
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
End With
Range("I1") = "No"
Range("J1") = "氏名"
Range("K1") = "最高点"
Range("L1") = "中間点１"
Range("M1") = "中間点２"
Range("N1") = "中間点３"
Range("O1") = "最小点"
Range("P1") = "合計点"
Range("A2:G2").Copy Range("I2:O2")
Range("K2:O2").Sort _
Key1:=Range("K2:O2"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K2").Interior.ColorIndex = 4
Range("O2").Interior.ColorIndex = 6
Range("P2").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),2)"
End With
End Sub
Sub Macro2()
With Range("P3").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A3:G3").Copy Range("I3:O3")
Range("K3:O3").Sort _
Key1:=Range("K3:O3"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K3").Interior.ColorIndex = 4
Range("O3").Interior.ColorIndex = 6
Range("P3").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),3)"
End Sub
Sub Macro3()
With Range("P4").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A4:G4").Copy Range("I4:O4")
Range("K4:O4").Sort _
Key1:=Range("K4:O4"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K4").Interior.ColorIndex = 4
Range("O4").Interior.ColorIndex = 6
Range("P4").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),4)"
End Sub
Sub Macro4()
With Range("P5").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A5:G5").Copy Range("I5:O5")
Range("K5:O5").Sort _
Key1:=Range("K5:O5"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K5").Interior.ColorIndex = 4
Range("O5").Interior.ColorIndex = 6
Range("P5").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),5)"
End Sub
Sub Macro5()
With Range("P6").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A6:G6").Copy Range("I6:O6")
Range("K6:O6").Sort _
Key1:=Range("K6:O6"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K6").Interior.ColorIndex = 4
Range("O6").Interior.ColorIndex = 6
Range("P6").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),6)"
End Sub
Sub Macro6()
With Range("P7").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A7:G7").Copy Range("I7:O7")
Range("K7:O7").Sort _
Key1:=Range("K7:O7"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K7").Interior.ColorIndex = 4
Range("O7").Interior.ColorIndex = 6
Range("P7").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),7)"
End Sub
Sub Macro7()
With Range("P8").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A8:G8").Copy Range("I8:O8")
Range("K8:O8").Sort _
Key1:=Range("K8:O8"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K8").Interior.ColorIndex = 4
Range("O8").Interior.ColorIndex = 6
Range("P8").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),8)"
End Sub
Sub Macro8()
With Range("P9").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A9:G9").Copy Range("I9:O9")
Range("K9:O9").Sort _
Key1:=Range("K9:O9"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K9").Interior.ColorIndex = 4
Range("O9").Interior.ColorIndex = 6
Range("P9").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),9)"
End Sub   
Sub TEST1()
Range("R7").Select
    Application.Width = 750.75
    Application.Height = 381.75
    Columns("P:P").Select
    Range("I1:P40").Sort Key1:=Range("P1"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    Dim myR As Range
    Dim Cel As Range
    Dim clrIdx As Integer
    Columns("P:P").Interior.ColorIndex = xlNone
    Set myR = Range("P2", Range("P" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel
              If .Value = .Offset(-1) Then
                    .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
              ElseIf .Value = .Offset(1) Then
                    clrIdx = IIf(clrIdx = 8, 7, 8)
                     .Interior.ColorIndex = clrIdx
             End If
          End With
     Next
 Range("P1").Select
 With Selection.Interior
  .ColorIndex = 15
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  End With
  End Sub
    Sub TEST2()
    Dim i As Long, x(), y(), myR As Range, Cel As Range, clrIdx As Long, ary
    Dim u As Integer, j As Integer, t As Integer, idx, z, b()
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    ary = Array("P", "Q", "R", "S")
    idx = Array(-2, -5, -7)
    For i = 2 To 41
        If Not IsEmpty(Range("P" & i)) And Application.CountIf(Range("P:P"), Range("P" & i)) > 1 Then
            ReDim Preserve x(j)
            x(j) = Range("P" & i).Address(0, 0)
            j = j + 1
        End If
    Next i
    For u = 1 To 3
        With Range(ary(u) & "1:" & ary(u) & "41").Borders
            .Weight = xlThin
            .ColorIndex = 1
        End With
        j = 0
        t = 0
        clrIdx = xlNone
        Set myR = Range(Join(x, ","))
        For Each Cel In myR
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, -2).Value
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, idx(u - 1)) + IIf(u = 3, Cel.Offset(, -3), 0)
            ReDim Preserve y(t)
            y(t) = Cel.Address(0, 0)
            data = Range("P" & Cel.Row).Value & "," & Cel.Offset(, 1).Value
            If Not dic.exists(data) Then
                dic(data) = Array(Cel.Offset(, 1).Address(0, 0))
            Else
                z = dic(data)
                ReDim Preserve z(UBound(z) + 1)
                z(UBound(z)) = Cel.Offset(, 1).Address(0, 0)
                dic(data) = z
            End If
            t = t + 1
        Next
        Range(ary(u) & 1) = "同点その" & StrConv(u, vbWide)
        Columns(u + 16).Interior.ColorIndex = xlNone
        Set myR = Range(Join(x, ",")).Offset(, 1)
        For Each Cel In myR
            With Cel
                If Not IsError(Application.Match(Cel.Offset(, -1).Address(0, 0), y, 0)) And _
                            Application.CountIf(Range(ary(u) & ":" & ary(u)), Cel) > 1 Then
                    data = Range("P" & Cel.Row) & "," & Cel.Value
                    If Not IsEmpty(dic(data)) Then
                        If dic.exists(data) And UBound(dic(data)) > 0 Then
                            For n = 0 To UBound(dic(data))
                                ReDim Preserve b(n)
                                b(n) = dic(data)(n)
                                ReDim Preserve x(j)
                                x(j) = b(n)
                                j = j + 1
                            Next
                            dic.Remove data
                            Range(Join(b, ",")).Interior.ColorIndex = Range(b(n - 1)) _
                                    .Offset(, -1).Interior.ColorIndex

                        End If
                    End If
                End If
              End With
         Next
         dic.removeall
         If j = 0 Then Exit For
    Next u
    Set dic = Nothing
    Dim myAreas As Areas, myArea As Range, a As Integer
    For a = 1 To 3
        On Error Resume Next
        Set myAreas = Columns(a + 16).SpecialCells(2, 1).Areas
        On Error GoTo 0
        If myAreas Is Nothing Then Exit Sub
        For Each myArea In myAreas
            With Application.Intersect(Range("I:S"), myArea.EntireRow)
                .Sort Key1:=.Cells(1, a + 8), Order1:=xlDescending, Header:=xlNo
            End With
        Next
    Range("Q1:S1").Select
 With Selection.Interior
  .ColorIndex = 15
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  End With
 With Range("Q1:S1").Font
  .FontStyle = "太字"
  End With
    Next
 End Sub

(甘太郎)

---

 単純に申せば
 Set dic = Nothing
 から下が不要です。このように変更すればよろしいかと思われます。

    Set dic = Nothing
    With Range("Q1:S1")
        .Interior.ColorIndex = 15
        .Interior.Pattern = xlSolid
        .Interior.PatternColor = xlatutomatic
        .Font.FontStyle = "太字"
    End With
 End Sub

 TEST1 の
     'Columns("P:P").Select ’この行不要
 と
' Range("P1").Select
' With Selection.Interior
'  .ColorIndex = 15
'  .Pattern = xlSolid
'  .PatternColorIndex = xlAutomatic
'  End With
 も不要です。
 なお
 ', DataOption1:=xlSortNormal
 もバージョンエラーが出ますから無くても結構です。

 なお、Macro1からMacro8までは同じ作業の繰り返しですから

 Sub Macro()
    Dim i As Long, mxrow As Long
    mxrow = Range("a" & Rows.Count).End(xlUp).Row
    With Range("I1:P1")
        With .Borders
            .Weight = xlThin
        End With
        With .Font
            .Name = "MSPゴシック"
            .Bold = True
            .ColorIndex = xlAutomatic
            .FontStyle = "太字"
            .OutlineFont = True
            .Size = 12
        End With
        With .Interior
            .ColorIndex = 15
            .Pattern = xlSolid
        End With
        With .Borders
            .Weight = xlThin
        End With
        .Value = Split("No 氏名 最高点 中間点１ 中間点２ 中間点３ 最小点 合計点")
    End With
    Range("I2").Resize(mxrow - 1, 7) = Range("A2").Resize(mxrow - 1, 7).Value
    For i = 2 To mxrow
        Cells(i, "K").Resize(, 5).Sort key1:=Cells(i, "K").Resize(, 5), Order1:= _
                xlDescending, Orientation:=xlSortRows
    Next i
    With Range("P2").Resize(mxrow - 1)
        .Formula = "=ROUND(SUM(L2:N2),2)"
        .Borders.Weight = xlThin
        .Offset(, -5).Interior.ColorIndex = 4
        .Offset(, -1).Interior.ColorIndex = 6
    End With
 End Sub

 これだけで事足ります。
 　　　　　（弥太郎）

---

弥太郎さん、いつもコメントありがとうございます。
アドバイスして頂いた通り、不要コードを削除し、下記コードに変えてやってみたところ、Ｑ列とＳ列で同点のグループ内の降順の並び替えが行なわれなくなりました。

 Sub TEST2()
    Dim i As Long, x(), y(), myR As Range, Cel As Range, clrIdx As Long, ary
    Dim u As Integer, j As Integer, t As Integer, idx, z, b()
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    ary = Array("P", "Q", "R", "S")
    idx = Array(-2, -5, -7)
    For i = 2 To 41
        If Not IsEmpty(Range("P" & i)) And Application.CountIf(Range("P:P"), Range("P" & i)) > 1 Then
            ReDim Preserve x(j)
            x(j) = Range("P" & i).Address(0, 0)
            j = j + 1
        End If
    Next i
    For u = 1 To 3
        With Range(ary(u) & "1:" & ary(u) & "41").Borders
            .Weight = xlThin
            .ColorIndex = 1
        End With
        j = 0
        t = 0
        clrIdx = xlNone
        Set myR = Range(Join(x, ","))
        For Each Cel In myR
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, -2).Value
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, idx(u - 1)) + IIf(u = 3, Cel.Offset(, -3), 0)
            ReDim Preserve y(t)
            y(t) = Cel.Address(0, 0)
            data = Range("P" & Cel.Row).Value & "," & Cel.Offset(, 1).Value
            If Not dic.exists(data) Then
                dic(data) = Array(Cel.Offset(, 1).Address(0, 0))
            Else
                z = dic(data)
                ReDim Preserve z(UBound(z) + 1)
                z(UBound(z)) = Cel.Offset(, 1).Address(0, 0)
                dic(data) = z
            End If
            t = t + 1
        Next
        Range(ary(u) & 1) = "同点その" & StrConv(u, vbWide)
        Columns(u + 16).Interior.ColorIndex = xlNone
        Set myR = Range(Join(x, ",")).Offset(, 1)
        For Each Cel In myR
            With Cel
                If Not IsError(Application.Match(Cel.Offset(, -1).Address(0, 0), y, 0)) And _
                            Application.CountIf(Range(ary(u) & ":" & ary(u)), Cel) > 1 Then
                    data = Range("P" & Cel.Row) & "," & Cel.Value
                    If Not IsEmpty(dic(data)) Then
                        If dic.exists(data) And UBound(dic(data)) > 0 Then
                            For n = 0 To UBound(dic(data))
                                ReDim Preserve b(n)
                                b(n) = dic(data)(n)
                                ReDim Preserve x(j)
                                x(j) = b(n)
                                j = j + 1
                            Next
                            dic.Remove data
                            Range(Join(b, ",")).Interior.ColorIndex = Range(b(n - 1)) _
                                    .Offset(, -1).Interior.ColorIndex
                        End If
                    End If
                End If
              End With
         Next
         dic.removeall
         If j = 0 Then Exit For
    Next u
    Set dic = Nothing
    With Range("Q1:S1")
  .Interior.ColorIndex = 15
  .Interior.Pattern = xlSolid
  .Interior.PatternColor = xlAutomatic
  .Font.FontStyle = "太字"
  End With
    Range("I1:I16").Copy Range("U1:U16")
    Range("U1") = "順位"
    Range("U:U").Select
    Selection.Sort key1:=Range("U2"), order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
    Range("J1:J16").Copy Range("V1:V16")
    End Sub

これは前にHANAさんから頂いた同点グループ内の降順の並び替えコード(下記)が削除されたためと思われます。
TEST2を実行した時に同点グループの並び替えが変わらない事と、同点グループ内の降順の並び替えの両方を満足させるためにはどこを変更すればよいでしょうか？
すみませんが宜しくお願いいたします。
Dim myAreas As Areas, myArea As Range, i As Integer

    For i = 1 To 3
        On Error Resume Next
        Set myAreas = Columns(i + 16).SpecialCells(2, 1).Areas
        On Error GoTo 0
        If myAreas Is Nothing Then Exit Sub
        For Each myArea In myAreas
            With Application.Intersect(Range("I:S"), myArea.EntireRow)
                .Sort key1:=.Cells(1, i + 8), order1:=xlDescending, Header:=xlNo
            End With
        Next
    Next

尚、マクロ１〜８までのコードについてですが、これはひとつずつ段階を踏んで処理したいためにこの様な形としました。

(甘太郎)

---

 どうやらマクロの記録をお試し頂けてないようでんなぁ。＾＾
 マクロの記録をまとめればこんな塩梅になります。
 set dic=nothing の下あたりに挿入すればよろしいかと・・・。 　　　　　　　
　　　　　　　　　　（弥太郎）
     With Range("I2").Resize(Range("I" & Rows.Count).End(xlUp).Row, 11)
        .Sort key1:=Range("P2"), order1:=xlDescending, key2:=Range("Q2"), order2:=xlDescending, _
                key3:=Range("R2"), order3:=xlDescending
        .Sort key1:=Range("P2"), order1:=xlDescending, key2:=Range("S2"), order2:=xlDescending
    End With
　　 

---

 弥太郎さんと、衝突しましたが
 そのまま載せておきます。

 あ〜、並べ替えに関しては
 二回目に載せたものを使ってみてください。

 その他の部分との兼ね合いに関しては
 考慮していませんので、ご了承下さい。

 ちなみに・・・・
 １回目の並べ替えでQ列,R列,S列の順で指定して並べ替えれば
 ２回目の並べ替えはP列のみの指定になります。

 (HANA)

---

弥太郎さん、HANAさん、色々とありがとうございます。
教えて頂いたコードで色々なケースでの検証をしてみます。

(甘太郎)

---

弥太郎さん、HANAさん、下記コードで色々とデータを変えて検証してみたところ、どんなケースにも全く問題なく期待した通りに動作する事が確認できました。ありがとうございました。
このままでも十分なのですが、以下の様な事も可能でしょうか？

TEST2で一括処理していた手順を３段階に分ける。つまり、同点その１、その２、その３をTEST2,TEST3,TEST4にコードを分けて処理したいと言う事です。
詳しく説明しますと、Ｐ列で同点があった場合、TEST2を実行するとＱ列で中間点３を加算して更にその同点のグループ内で降順に並び替える(同点その１)。更に、もしＱ列でも同点の場合、今度はTEST3で中
間点１を加算して同じ様にそのグループ内で降順に並び替える(同点その２)。最後に、もしＲ列でも同点であった場合、今度はTEST4で最高点と最小点の合計を加算して同じ様にそのグループ内で降順に並び替える(同点その３)と言う事です。
また、TEST2を実行してＱ列で順位がついてしまった場合でも、このコードだとＲ列、Ｓ列の見出しの部分のパターンがそのまま表示されてしまうのですが、これをＱ列、またはＲ列で順位がついた場合はそれ以降は見出しの部分の表示のセルは見出し、パターン、色、罫線等を全くのブランクにしたいのですが。
尚、コードの一部に書式設定など、自分なりに手を加えたところもあります。
色々と難しい事を言って申し訳ありませんが宜しくお願いいたします。

Sub Macro1()
Range("H:X").HorizontalAlignment = xlCenter
Range("H:X").NumberFormat = "#,##0.0"
With Range("I1:P2").Borders

  .Weight = xlThin
  .ColorIndex = 1
End With
With Range("I1:P1").Font
  .Name = "MS P ゴシック"
  .Bold = True
  .ColorIndex = 1
  .FontStyle = "太字"
  .OutlineFont = True
  .Size = 12
Range("I1:P1").Select
With Selection.Interior
  .ColorIndex = 15
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
End With
Range("I1") = "No"
Range("J1") = "氏名"
Range("K1") = "最高点"
Range("L1") = "中間点１"
Range("M1") = "中間点２"
Range("N1") = "中間点３"
Range("O1") = "最小点"
Range("P1") = "合計点"
Range("A2:G2").Copy Range("I2:O2")
Range("K2:O2").Sort _
Key1:=Range("K2:O2"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K2").Interior.ColorIndex = 4
Range("O2").Interior.ColorIndex = 6
Range("P2").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),2)"
End With
End Sub
Sub Macro2()
With Range("P3").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A3:G3").Copy Range("I3:O3")
Range("K3:O3").Sort _
Key1:=Range("K3:O3"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K3").Interior.ColorIndex = 4
Range("O3").Interior.ColorIndex = 6
Range("P3").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),3)"
End Sub
Sub Macro3()
With Range("P4").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A4:G4").Copy Range("I4:O4")
Range("K4:O4").Sort _
Key1:=Range("K4:O4"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K4").Interior.ColorIndex = 4
Range("O4").Interior.ColorIndex = 6
Range("P4").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),4)"
End Sub
Sub Macro4()
With Range("P5").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A5:G5").Copy Range("I5:O5")
Range("K5:O5").Sort _
Key1:=Range("K5:O5"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K5").Interior.ColorIndex = 4
Range("O5").Interior.ColorIndex = 6
Range("P5").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),5)"
End Sub
Sub Macro5()
With Range("P6").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A6:G6").Copy Range("I6:O6")
Range("K6:O6").Sort _
Key1:=Range("K6:O6"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K6").Interior.ColorIndex = 4
Range("O6").Interior.ColorIndex = 6
Range("P6").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),6)"
End Sub
Sub Macro6()
With Range("P7").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A7:G7").Copy Range("I7:O7")
Range("K7:O7").Sort _
Key1:=Range("K7:O7"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K7").Interior.ColorIndex = 4
Range("O7").Interior.ColorIndex = 6
Range("P7").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),7)"
End Sub
Sub Macro7()
With Range("P8").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A8:G8").Copy Range("I8:O8")
Range("K8:O8").Sort _
Key1:=Range("K8:O8"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K8").Interior.ColorIndex = 4
Range("O8").Interior.ColorIndex = 6
Range("P8").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),8)"
End Sub
Sub Macro8()
With Range("P9").Borders
  .Weight = xlThin
  .ColorIndex = 1
End With
Range("A9:G9").Copy Range("I9:O9")
Range("K9:O9").Sort _
Key1:=Range("K9:O9"), Order1:=xlDescending, Orientation:=xlSortRows
Range("K9").Interior.ColorIndex = 4
Range("O9").Interior.ColorIndex = 6
Range("P9").Select
ActiveCell.FormulaR1C1 = "=ROUND(SUM(RC[-4]:RC[-2]),9)"
End Sub
Sub TEST1()
Range("R7").Select
    Application.Width = 750.75
    Application.Height = 381.75
    Columns("P:P").Select
    Range("I1:P40").Sort Key1:=Range("P1"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    Dim myR As Range
    Dim Cel As Range
    Dim clrIdx As Integer
    Columns("P:P").Interior.ColorIndex = xlNone
    Set myR = Range("P2", Range("P" & Rows.Count).End(xlUp))
     For Each Cel In myR
          With Cel
              If .Value = .Offset(-1) Then
                    .Interior.ColorIndex = .Offset(-1).Interior.ColorIndex
              ElseIf .Value = .Offset(1) Then
                    clrIdx = IIf(clrIdx = 8, 7, 8)
                     .Interior.ColorIndex = clrIdx
             End If
          End With
     Next
 Range("P1").Select
 With Selection.Interior
  .ColorIndex = 15
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  End With
  End Sub
 Sub TEST2()
 Range("U:U").NumberFormat = "#,##0"
    Dim i As Long, x(), y(), myR As Range, Cel As Range, clrIdx As Long, ary
    Dim u As Integer, j As Integer, t As Integer, idx, z, b()
    Dim dic As Object
    Set dic = CreateObject("scripting.dictionary")
    ary = Array("P", "Q", "R", "S")
    idx = Array(-2, -5, -7)
    For i = 2 To 41
        If Not IsEmpty(Range("P" & i)) And Application.CountIf(Range("P:P"), Range("P" & i)) > 1 Then
            ReDim Preserve x(j)
            x(j) = Range("P" & i).Address(0, 0)
            j = j + 1
        End If
    Next i
    For u = 1 To 3
        With Range(ary(u) & "1:" & ary(u) & "41").Borders
            .Weight = xlThin
            .ColorIndex = 1
        End With
        j = 0
        t = 0
        clrIdx = xlNone
        Set myR = Range(Join(x, ","))
        For Each Cel In myR
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, -2).Value
            Cel.Offset(, 1).Value = Cel + Cel.Offset(, idx(u - 1)) + IIf(u = 3, Cel.Offset(, -3), 0)
            ReDim Preserve y(t)
            y(t) = Cel.Address(0, 0)
            data = Range("P" & Cel.Row).Value & "," & Cel.Offset(, 1).Value
            If Not dic.exists(data) Then
                dic(data) = Array(Cel.Offset(, 1).Address(0, 0))
            Else
                z = dic(data)
                ReDim Preserve z(UBound(z) + 1)
                z(UBound(z)) = Cel.Offset(, 1).Address(0, 0)
                dic(data) = z
            End If
            t = t + 1
        Next
        Range(ary(u) & 1) = "同点その" & StrConv(u, vbWide)
        Columns(u + 16).Interior.ColorIndex = xlNone
        Set myR = Range(Join(x, ",")).Offset(, 1)
        For Each Cel In myR
            With Cel
                If Not IsError(Application.Match(Cel.Offset(, -1).Address(0, 0), y, 0)) And _
                            Application.CountIf(Range(ary(u) & ":" & ary(u)), Cel) > 1 Then
                    data = Range("P" & Cel.Row) & "," & Cel.Value
                    If Not IsEmpty(dic(data)) Then
                        If dic.exists(data) And UBound(dic(data)) > 0 Then
                            For n = 0 To UBound(dic(data))
                                ReDim Preserve b(n)
                                b(n) = dic(data)(n)
                                ReDim Preserve x(j)
                                x(j) = b(n)
                                j = j + 1
                            Next
                            dic.Remove data
                            Range(Join(b, ",")).Interior.ColorIndex = Range(b(n - 1)) _
                                    .Offset(, -1).Interior.ColorIndex

                        End If
                    End If
                End If
              End With
         Next
         dic.removeall
         If j = 0 Then Exit For
    Next u
    Set dic = Nothing
    With Range("I2").Resize(Range("I" & Rows.Count).End(xlUp).Row, 11)
        .Sort Key1:=Range("P2"), Order1:=xlDescending, key2:=Range("Q2"), order2:=xlDescending, _
                key3:=Range("R2"), order3:=xlDescending
        .Sort Key1:=Range("P2"), Order1:=xlDescending, key2:=Range("S2"), order2:=xlDescending
    End With
    With Range("Q1:S1")
  .Interior.ColorIndex = 15
  .Interior.Pattern = xlSolid
  .Interior.PatternColor = xlAutomatic
  .Font.FontStyle = "太字"
  End With
    Range("I1:I16").Copy Range("U1:U16")
    Range("U1") = "最終順位"
    Range("U:U").Select
    Selection.Sort Key1:=Range("U2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
    Range("J1:J16").Copy Range("V1:V16")
    Range("W1").Select
    End Sub

(甘太郎)

---

 これはコードをデバックすればお分かりかと存じますが
 Jの値に注目しませう。
 TEST2のコードの左側に縦に走るグレーゾーンがありますから、そこをクリックして
 （ブレークポイントと言ってコードが茶色に染まる）コードを走らせます。 
 F8でステップインすれば、（マウスを変数などに近づける）その変数の値が逐一ご理解
 頂けると思いまっせぇ。

 つまりJの値が0なら同点決勝に進むデータが存在しない事になりますんで、
 もしJが0なら
 For u=1 to 3 
 に走らないコードを書き加えればええだけの話ですわ。
 また　uが1とか2とかでjが0ならループを抜け出すように組み込んでありますから
 甘太郎はんの意に添うたコードになっとります。
 罫線、その他は元々あんさんが作ったコードなんで、当方はいじっていまへん。

 With Range("Q1:S1")の変わりに
 With Range("Q1").Resize(, u)
 とすればよろしいかと思われます。
 ただuが0だとエラーが出ますから
 その上の行に
 On Error Resume Next
 とでも挿入しておけばOKですワ。

 ステップインを繰り返して、マクロがどんな作業を繰り返しているか検証しませう。
 　　　　（弥太郎）

---

 一つだけ書いておきます。
 ＞下記コードで色々とデータを変えて検証してみたところ、
 ＞どんなケースにも全く問題なく期待した通りに動作する事が確認できました。
 と言う事ですが
 並べ替えの基本は、優先順位の低い物から行います。

 ↓この様に並ぶのが　ご希望なんじゃないですか？
	[P]	[Q]	[R]	[S]
[1]	合計点	同点１	同点２	同点３
[2]	5	4	3	2
[3]	5	4	3	1
[4]	5	4	2	2
[5]	5	4	2	1

 問題ないなら良いですが。

 (HANA)

---

弥太郎さん、HANAさん、
お二人に色々と教えて頂いたコードを見本にしてマクロの基本を一から勉強してみます。
ご親切にアドバイスをして頂き、本当にありがとうございました。

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.