エクセル2003 VBAなのですが

質問

エクセル2003　VBAなのですが

　　A　　 B　　 　C　　 　D　　 　E　　 　F
1　あ　　　い　　　う　　　お　　　う　　　123
2 お　　　さ　　　え　　　あ　　　お　　　お
3　あ　　　い　　　え　　　お　　　え　　　888

上記のような表があるときに　3個以上同じ文字がある場合にセルに色をつけていきたい状況です
上記表でいうと『あ』と『え』と『お』のセルに色をつけたいのです
セルには文字列のほかに数字も入っている状況です
単純にCtrl+Fで検索をして『すべて検索』で　出てきたセル全部に色をつける。
それをA1から文字があるところ全部やる　と言った事をマクロでやりたいと思っております。

皆様よろしくお願いいたします。

回答No.3

keithin · ベストアンサー

＃ありゃりゃ，はずいですね。
失礼しました。

Sub macro2()
　Dim h As Range
　Dim i
　i = 2
　Cells.Interior.ColorIndex = xlNone
　On Error Resume Next

　For Each h In Cells.SpecialCells(xlCellTypeConstants)
　　If Application.CountIf(ActiveSheet.UsedRange, h) >= 3 Then
　　　If h.Interior.ColorIndex = xlNone Then
　　　　i = i + 1
　　　　Application.ReplaceFormat.Clear
　　　　Application.ReplaceFormat.Interior.ColorIndex = i
　　　　Cells.Replace What:=h, Replacement:=h, lookat:=xlWhole, ReplaceFormat:=True
　　　End If
　　End If
　Next
End Sub

お礼

ばっちり動きました。　何度もお手数かけました
ありがとうございます。

回答No.4

mt2008

連想配列を使ってみました。
色は54色以上が必要になるとそれ以上は54色目と同じ色に塗りつぶします。

Sub Sample()
　Set rng = Range("A1:F3")　'←この範囲が対象

　'連想配列で要素の個数を取得
　Set rng = Range("A1:F3")
　Set dic = CreateObject("Scripting.Dictionary")
　For Each ele In rng.Value
　　If ele <> "" Then dic(ele) = dic(ele) + 1
　Next

　'Keyを配列に取得
　dKey = dic.keys

　'Key要素数が3以上なら色番号を割り振る
　'黒、白を除いた色番号3～56までを対象。
　colnum = 3
　For i = 0 To (dic.Count - 1)
　　If dic(dKey(i)) >= 3 Then
　　　dic(dKey(i)) = colnum
　　　colnum = colnum + 1
　　　If colnum > 56 Then colnum = 56
　　Else
　　　dic(dKey(i)) = 0
　　End If
Next i

　'色番号が付いているならその色で塗りつぶす
　For Each trg In rng
　　If (trg.Value <> "") And (dic(trg.Value) > 0) Then
　　　trg.Interior.ColorIndex = dic(trg.Value)
　　End If
　Next

End Sub

回答No.2

Wendy02

質問がはっきりしない部分がありますが、考えてみました。

>セルには文字列のほかに数字も入っている状況です
>Ctrl+Fで検索をして『すべて検索』で　出てきたセル全部に色をつける。
>A1から文字があるところ全部やる　

数字に関しては、除外するという意味でしょうか。
VarType(c) = vbString というのを付け足しました。

もし、文字ごとに色を変えるとしたら、少し限界があるかもしれません。

'//
Sub CoutDoubledTest()
　　Dim rng As Range
　　Dim c As Range
　　Set rng = Range("A1").CurrentRegion
　　rng.Interior.ColorIndex = xlColorIndexNone
　　Application.ScreenUpdating = False
　　For Each c In rng
　　　　If WorksheetFunction.CountIf(rng, c.Value) > 2 And _
　　　　　　VarType(c) = vbString Then
　　　　　　c.Interior.ColorIndex = 34
　　　　End If
　　Next c
　　Application.ScreenUpdating = True
　　Set rng = Nothing
End Sub

補足

お返事ありがとうございます。
ほぼパーフェクトです！！
後は色が・・・　色は何でもいいんですが変わらないですか？
ランダムでもまったく問題ないのですが・・・
もしよろしければお返事いただけますと幸いです。
よろしくお願いいたします。

回答No.1

keithin

方法１
セル範囲（例ではA1:F3）を選ぶ
書式メニューの条件付き書式を開始する
セルの値が　→　数式が　に変えて
右の空欄に
=COUNTIF($A$1:$F$3,A1)>=3
と記入し，書式ボタンで色を付ける
以上です。

といった操作を新しいマクロの記録にして利用しても，勿論構いません。

方法２
sub macro2()
　dim h as range
　cells.interior.colorindex = xlnone '←不要なら無くても良い
　on error resume next
　for each h in union(cells.specialcells(xlcelltypeconstants), cells.specialcells(xlcelltypeformulas))
　　if application.countif(activesheet.usedrange, h) >= 3 then
　　　h.interior.colorindex = 4
　　end if
　next
end sub

補足

For Each h In Union(Cells.SpecialCells(xlCellTypeConstants), Cells.SpecialCells(xlCellTypeFormulas))
のところでエラーがかかってしまいます；；
該当するセルが見つかりません　
とでてしまいます。
あと追加なのですが　『あ』と『う』と『お』（まだまだある状況になりますが・・・）の
セルの色は変えたい状況です。
イメージとしては『あ』がパッと見た状況でどこにどれだけあるかが知りたい状況です。
よろしくお願いいたします。