excel_特定のセル範囲で同じ文字列が有ったら色

質問

マクロ初心者です。
excel2002マクロ_特定のセル範囲で同じ文字列が有ったらその数によりセルを色分けしたい

特定のセル範囲で文字列が入っているところと空欄のところがあります。
空欄のところには、後から文字列が入るところと空欄のままのところがあります。
その範囲内で同じ文字列があった場合、2個の時、3個の時、4個の時、5個、6個、7個、8個、9個、10個以上の時に、それぞれ決めておいた色でセルを色分け表示したいです。
文字列の順番はランダムです。

excel2002なので、3種類までなら条件付き書式で設定できるのですが、それを超える場合は設定できません。
それで、これをマクロで設定できるでしょうか。

条件付き書式で設定した場合は、文字列を入力した時点でセルの色はすぐに反映されますが、マクロの場合もそのようにすることは可能でしょうか。

よろしくお願いします。

回答No.4

kkkkkm · ベストアンサー

回答1No.1No.2のおまけです。

色が多いので各色が何個の時の色なのかが分かりにくいと思いますので

どこかに色見本的なセルを設けて

たとえばN列のセルに色を付けてO列にその色が何個の時なのか記載しておいて
N1に2個の時の色があるとしたら

Case 2
mRng.Interior.Color = Range("N1").Interior.Color

以下同じようにし指定

とすれば分かりやすいかもしれません。

お礼

ありがとうございます。
自分用に色々試しているところです。

補足

「おまけ」にすると分かりやすくて良いですね。
非力なPCで使っているので、試しに範囲を一番下の65,536行までにしてみたところ、1回入力する度に数秒間ビジー状態になりました。
範囲をそこまで広げることは無いので問題にならないと思います。

回答No.5

kkkkkm

> 試しに範囲を一番下の65,536行までにしてみたところ、1回入力する度に数秒間ビジー状態になりました。

色だとどうしてもセルに都度アクセスしないといけないので時間がかかりますね。

最初の方の
Application.EnableEvents = False
の後に
Application.ScreenUpdating = False

と

最後の
Application.EnableEvents = True
の前に
Application.ScreenUpdating = True

とすれば多少は変わるかもしれません。

あと、たぶん色なしの方が多いだろうなと思って検索時に結果を見て一つ一つ色なしにするより最初に範囲全て色なしにたほうが早いのじゃないかなと思って(試していないので私の思い込みの可能性もあります)

Range("B3:C27").Interior.ColorIndex = xlNone

としているのですが

色なしの方が少ないのでしたら

Case Is >= 10
mRng.Interior.Color = vbCyan
Case Else
mRng.Interior.Color = xlNone
End Select

とCase Elseのところに色なし設定をすると多少かわるかもしれません。

補足

色なしの設定を変えて、範囲を65,536行にしてみたところ、ビジーがかなり長い時間になってしまいました。
空欄のところが多かったためかもしれません。

今使っている状態では100件になっていません。
今後増えていきますが、範囲は余裕をあまり大きくしないで使おうと思います。
ありがとうございました。

回答No.3

SI299792

どのように色を指定するのかわからないし、９色指定するのは大変なので、ColorIndexを使いました。
２つ☞赤、３つ☞緑…
濃い色だと醜いので、その場合フォントを白にする機能を付けました。
範囲はA1～N12 にしてあります。変更して下さい。
Option Explicit
'
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim Area As Range
　　Dim Count As Integer
'
　　Set Area = [A1:N12]
'
　　If Intersect(Target, Area) Is Nothing Then
　　　　End
　　End If
'
　　For Each Target In Area
　　　　Count = WorksheetFunction.CountIf(Area, Target)
　　　　Count = WorksheetFunction.Min(Count, 10)
'
　　　　If Count < 2 Then
　　　　　　Target.Interior.Pattern = xlNone
　　　　Else
　　　　　　Target.Interior.ColorIndex = Count + 1
　　　　End If
　　　　Target.Font.Color = FontColor(Target.Interior.Color)
　　Next Target
End Sub
'
Function FontColor(ByVal IColor As Long) As Long
　　Dim SColor As Integer
　　Dim Mul As Integer
'
　　Mul = 1
'
　　Do While IColor > 0
　　　　Mul = Mul Mod 3 + 1
　　　　SColor = SColor + (IColor Mod 256) * Mul
　　　　IColor = IColor \ 256
　　Loop
　　FontColor = vbWhite * -(SColor < 764)
End Function

シートモジュールに入れて下さい。
シート名の所を右クリック、コードの表示を選び、そこに入れて下さい。

お礼

ありがとうございます。
色々試しています。

補足

セルが濃い色だと黒い文字は見難いので白文字にするのは良いですね。
この部分だけ組み込ませてもらおうと思います。
ありがとうございました。

回答No.2

kkkkkm

回答No.1は一列だけ対応してますが

複数列の範囲を数えるのなら

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("B3:C27")) Is Nothing Then
Exit Sub
End If

Application.EnableEvents = False

Dim mRng As Range

Range("B3:C27").Interior.ColorIndex = xlNone

For Each mRng In Range("B3:C27")
Select Case WorksheetFunction.CountIf(Range("B3:C27"), mRng.Value)
Case 2
mRng.Interior.Color = vbYellow
Case 3
mRng.Interior.Color = vbBlue
Case 4
mRng.Interior.Color = vbGreen
Case 5
mRng.Interior.Color = vbRed
Case Is >= 10
mRng.Interior.Color = vbCyan
Case Else
End Select
Next

Application.EnableEvents = True

End Sub

複数列対応だけど数える範囲はそのセルと同じ列だけ(No.1の対応範囲を広げるだけ）

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("B3:C27")) Is Nothing Then
Exit Sub
End If

Application.EnableEvents = False

Dim mRng As Range

Range("B3:C27").Interior.ColorIndex = xlNone

For Each mRng In Range("B3:C27")
Select Case WorksheetFunction.CountIf(Range(Cells(3, mRng.Column), Cells(27, mRng.Column)), mRng.Value)
Case 2
mRng.Interior.Color = vbYellow
Case 3
mRng.Interior.Color = vbBlue
Case 4
mRng.Interior.Color = vbGreen
Case 5
mRng.Interior.Color = vbRed
Case Is >= 10
mRng.Interior.Color = vbCyan
Case Else
End Select
Next

Application.EnableEvents = True

End Sub

回答No.1

kkkkkm

範囲が分からないのでB3:B27としてます。該当シートのマクロに以下をコピペしてみてください。実行されたら手入力の時のように元の戻すはききません。

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("B3:B27")) Is Nothing Then
Exit Sub
End If

Application.EnableEvents = False

Dim mRng As Range

Range("B3:B27").Interior.ColorIndex = xlNone

For Each mRng In Range("B3:B27")
Select Case WorksheetFunction.CountIf(Range(Cells(3, mRng.Column), Cells(27, mRng.Column)), mRng.Value)
Case 2
mRng.Interior.Color = vbYellow
Case 3
mRng.Interior.Color = vbBlue
Case 4
mRng.Interior.Color = vbGreen
Case 5
mRng.Interior.Color = vbRed
'この間に残りを同じように指定して下さい
Case Is >= 10
mRng.Interior.Color = vbCyan
Case Else
End Select
Next

Application.EnableEvents = True

End Sub

色は以下のサイトで
VBAカラー一覧(組み込み定数、RGB値、16進数)｜色見本あり
https://excel-toshokan.com/vba-color-list/