[[20060116181035]]　『出現数の多い値のセルを色付け』（NOBU）　ページの最後に飛ぶ

『出現数の多い値のセルを色付け』（NOBU）

    A          T   U   V   W   X   Y   Z  AA  AB         AM
  +---+  ～  +---+---+---+---+---+---+---+---+---+  ～　+---+
1 |   |  ～  |   |   |   |   |   |   |   |   |   |  ～　|   |
  +---+  ～  +---+---+---+---+---+---+---+---+---+  ～　+---+
2 |   |  ～  |   |   |   |   |   |   |   |   |   |  ～　|   |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+
3 |   |  ～  |0  |0  |0  |2  |3  |5  |0  |8  |12 |　～  |0  |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+
4 |   |  ～  |1  |2  |3  |0  |0  |0  |0  |9  |15 |　～  |0  |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+
5 |   |  ～  |0  |0  |3  |6  |8  |9  |0  |0  |0  |　～  |12 |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+
6 |   |  ～  |0  |0  |0  |2  |0  |3  |0  |7  |12 |　～  |0  |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+
    |    |     |   |   |   |   |   |   |   |   |    |     |
    |    |     |   |   |   |   |   |   |   |   |    |     |
    |    |     |   |   |   |   |   |   |   |   |    |     |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+
34|   |  ～  |0  |0  |0  |2  |0  |5  |0  |6  |12 |　～  |15 |
  +---+  ～  +---+---+---+---+---+---+---+---+---+　～　+---+

はじめまして、よろしくご教授お願いいたします。

上記のようなシートがあるのですが、検索範囲をＴ３：ＡＭ３４とし、

値ゼロを除き出現数の１番多い値のセルを赤に、２番目に多いセルを黄に、

塗りつぶすようなマクロがあれば、いいのですがよろしくお願いいたします。

補足

検索範囲は実際の範囲と同じです。

塗りつぶすのは１番多い値のセルと２番目に多いセルのみ。（０は除く）

値は計算式で求めたものです。

環境はWindowsXP、EXEL2002です。

 これでご希望のようになりますでしょうか。
　
Sub Test()
Dim MyRange As Range, MyAreaRange1 As Range, MyAreaRange2 As Range
Dim c As Range, r1 As Range, r2 As Range
Dim MyR As Long, MyC As Long, MyCount As Long
Dim MyA(1 To 32, 1 To 20)
　
Set MyRange = Worksheets("Sheet1").Range("T3:AM34")
MyRange.Interior.ColorIndex = 0
For Each c In MyRange
    MyR = c.Row - 2
    MyC = c.Column - 19
    If c.Value <> 0 Then
        MyCount = Application.CountIf(MyRange, c)
    Else
        MyCount = 0
    End If
        MyA(MyR, MyC) = MyCount
Next c
最頻数 = Application.Large(MyA, 1)
次頻数 = Application.Large(MyA, 最頻数 + 1)
For Each c In MyRange
    MyR = c.Row - 2
    MyC = c.Column - 19
    If 最頻数 = MyA(MyR, MyC) Then
        最頻値 = c.Value
        MyFlg1 = 1
    ElseIf 次頻数 = MyA(MyR, MyC) Then
        次頻値 = c.Value
        MyFlg2 = 1
    End If
    If MyFlg1 + MyFlg2 = 2 Then Exit For
Next c
　
Set r1 = MyRange.Find(最頻値, LookIn:=xlFormulas)
Set r2 = MyRange.Find(次頻値, LookIn:=xlFormulas)
Set MyAreaRange1 = r1
Set MyAreaRange2 = r2
For Each c In MyRange
    If c = 最頻値 Then
        Set MyAreaRange1 = Union(c, MyAreaRange1)
    ElseIf c = 次頻値 Then
        Set MyAreaRange2 = Union(c, MyAreaRange2)
    End If
Next c
MyAreaRange1.Interior.ColorIndex = 3
MyAreaRange2.Interior.ColorIndex = 6
　
Set MyAreaRange1 = Nothing
Set MyAreaRange2 = Nothing
Set MyRange = Nothing
Set r1 = Nothing
Set r2 = Nothing
End Sub

 （川野鮎太郎）

川野様、早速お答えいただきありがとうございます。

試してみましたが　”最頻数 = " のところで、コンパイルエラー

”変数が定義されていません”のメッセージがでてしまいます。

Dimで定義しても、次頻数や最頻値やMyFlg1などが次々と同じエラーに

なっていしまいます。よろしくお願いいたします。(NOBU)

 行頭にOption Explicitが記述されていると思いますので、
 その行をコメントアウトして試すか、エラーが出る定数を全て定義してください。

 （川野鮎太郎）

 Dictiona objectを使用した方法です...
 該当する値が複数存在する場合は、出現順の早いものになっています。

 Sub test()
 Dim dic As Object, x, y, z, Colrng As Range
 Dim i As Long, rng As Range, r As Range
 Dim maxRng As Range, ff As String
 Set dic = CreateObject("scripting.dictionary")
 Set rng = Range("t3:am34")
 rng.Interior.ColorIndex = 0
 For Each r In rng
     If Not IsEmpty(r) And r <> 0 Then
         If Not dic.exists(r.Value) Then
             dic.Add r.Value, 1
         Else
             dic(r.Value) = dic(r.Value) + 1
         End If
     End If
 Next
 x = dic.keys: y = dic.items
 For i = 1 To 2
     z = Application.Max(y, 1)
     z = Application.Match(z, y, 0)
     Set maxRng = rng.Find(x(z - 1), , , xlWhole)
     If Not maxRng Is Nothing Then
         ff = maxRng.Address
         Set Colrng = maxRng
         Do
             Set maxRng = rng.FindNext(maxRng)
             Set Colrng = Union(Colrng, maxRng)
         Loop Until maxRng.Address = ff
         If i = 1 Then
             Colrng.Interior.Color = vbRed
         Else
             Colrng.Interior.Color = vbYellow
         End If
         x(z - 1) = Application.Min(x)
         Set maxRng = Nothing: ff = Empty
         Set Colrng = Nothing
     End If
 Next
 Set dic = Nothing: Set rng = Nothing
 End Sub
 (seiya)

川野様、seiya様、ありがとうございました。

一点だけですが最頻値、次頻値と同数字を持つ最初に出現する計算式も

引っ掛かるようです。（最頻値が５としたら例えば計算式に＄Ｐ５と入っていると

赤くなってしまいます。）（NOBU）

 失礼しました。そのつもりは無かったのですが、知らずに数式を探すようにしてました。
 以下の部分を訂正しておいてください。
(間違い)
 Set r1 = MyRange.Find(最頻値, LookIn:=xlFormulas)
 Set r2 = MyRange.Find(次頻値, LookIn:=xlFormulas)
　
（訂正）
 Set r1 = MyRange.Find(最頻値, LookIn:=xlValues)
 Set r2 = MyRange.Find(次頻値, LookIn:=xlValues)

 （川野鮎太郎）

 間違っていたらごめんなさい....

 >最頻数 = Application.Large(MyA, 1)
 次頻数 = Application.Large(MyA, 最頻数 + 1)

 次頻数はこれでいいのですか？(seiya)

 ＞次頻数はこれでいいのですか？
 はい、それで良い筈です。
 配列に重複する個数を入れて、最頻数+1で次頻数としてます。
 判りづらいかも知れませんので、以下の例で判りますか・・・。
 ↓下のような数値があったとして、個数を配列に入れる。
 5	4個　←配列に入れた個数を大きいほうから、最頻数+1（ここでは4個+1）
 3	1個　　で5番目に大きい数値の『3個』が次頻数って感じです。
 5	4個
 5	4個　　そのあとで、個数の配列から一致するセルの値を求めました。
 2	1個
 4	3個　　何かまどろっこしい感じですが、それしか思い浮かびませんでした。＿/￣|○ il||li
 1	1個
 4	3個　　最頻数だけならMODE関数でいけるんですけどね。
 4	3個
 5	4個

 （川野鮎太郎）

 川野鮎太郎さん、
 ご説明ありがとうございました。
 なるほど、どちらかというと、Rankの機能を持たせたような感じですか？
 考えが深い!
 (seiya)

川野様、seiya様、ありがとうございました。

何か初心者の私には、わからない話になってしまいましたが･･･(^_^;)

何度か検証しましたが、上手くいく時もあれば、検索する値によっては、

関係のない値に色（１箇所のみ）がついてしまったりする時がありますが、

あまり支障はないので、使用しています。

＞最頻数だけならMODE関数でいけるんですけどね。

素人考えですがVBAで使用できる関数なら、最頻数を赤にし、つぎに同じ検索範囲

から、色の付いていないセルだけを検索範囲にして、再度、最頻数を求めれば、

次頻数になるのかな？

お手数をおかけしました。ありがとうございました。（NOBU）

コメント返信：

[ 一覧(最新更新順) ]

[[20060116181035]] 『出現数の多い値のセルを色付け』（NOBU） ページの最後に飛ぶ

[[20060116181035]]　『出現数の多い値のセルを色付け』（NOBU）　ページの最後に飛ぶ