エクセルの条件付き書式について

質問

エクセル2002を使用しています。（2003でも可）
30個の会社名があります。それを6つのグループに分けて、フォントの色で区別たいと考えています。
例えば、1～5番の会社は赤、6～10番は青、・・26～30番は緑です。

実際に利用するときは、セルにリストを設定しておき、30個の会社名の中から、一つを選択します。
その時、あらかじめ設定されたフォントの色に変わるようにしたいのです。
書式メニューの条件付き書式では、書式のパターンが3つまでで、今回は6色必要なのでうまくいきません。
マクロで設定する方法も試みましたが、リストから選択したら瞬時に変わるようにして欲しいとの
要望があり、ダメでした。何かよいアイデアがあれば教えてください。よろしくお願いします。

回答No.1

shkwta · ベストアンサー

マクロのシートモジュールに、
Private Sub Worksheet_Change(ByVal Target As Range)
と書いてその中にマクロの命令を書けば、シートのどこかのセルの値が変更されたとき自動的に実行されます。（参考URL)

参考URL：

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1484384

お礼

教えていただいた構文を使ってうまくできました！
ありがとうございました。

回答No.3

Wendy02

こんにちは。

ちょっと変わった書き方かもしれませんね。いつも調べるのが面倒なので、列挙型で、色を選べるようにしました。

イベントマクロの方は、内容を読んで、設定してください。最初に、「会社リスト」の範囲を、名前で登録しなければ出来ません。

セルでグループ別けは、横に付けてください。
[会社リスト]
1行目 1～5番
2行目 6～10番
3行目 11～15番
4行目 16～20番
　　・
　　・
'<シートモジュール>
Option Explicit
Option Base 1
Private Enum myColor
'色番号(ColorIndex)
　mred = 3 '赤
　mapple = 4 '黄緑
　mblue = 5 '青
　myellow = 6 '黄色
　mpink = 7 'ピンク
　msky = 8 '水色
　mbrown = 9 ' 茶
　mgreen = 10 '緑
　mnavyb = 11 '藍
　mocher = 12 '黄土色
　mpurple = 13 '紫
　mmint = 14 '深緑
　mgrey = 15 '灰色
　mggrey = 16 'ねずみ色
　mhrznBle = 34 '淡い水色
　mgold = 44 'ゴールド
　morange = 45 'オレンジ
End Enum

Private Sub Worksheet_Change(ByVal Target As Range)
　Dim i As Long, j As Long
　Dim myColorArray()
　'----------------------------------
　'最初に、ワークシートメニューの[挿入]-[名前]で、
　'「会社リスト」で、範囲を定義してください。
　'----------------------------------------------------------
　'Range("A:A") を入力で、条件で色を変える範囲を設定してください。
　 If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
　'----------------------------------------------------------
　'
　If IsEmpty(Target) Or Target.Count > 1 Then Exit Sub
　myColorArray = Array(mred, mblue, mgreen, mapple, mpurple, morange)
　With Range("会社リスト")
　　For i = 1 To .Rows.Count
　　　If Application.CountIf(.Rows(i), Target.Value) > 0 Then
　　　　j = i
　　　　Exit For
　　　End If
　　Next i
　　If j > 0 Then
　　Target.Font.ColorIndex = myColorArray(j)
　　j = 0
　　Else
　　Target.Font.ColorIndex = 0 '色戻し
　　End If
　End With
End Sub

お礼

色番号を使う方法が参考になりました。
どうもありがとうございました！

回答No.2

KenKen_SP

こんにちは。KenKen_SP です。

> マクロで設定する方法も試みましたが...

こんな感じで、いけるかと。ただし、セルの値に変化があると一々
チェックするという安直な方法ですし、何だか自分でもコードを書
いてて「効率の悪いコードだなぁ」と思ってしまうものです。
パフォーマンスは悪いです。

でも、他に方法が思いつかないのでアップします（^^;)

下記のコードのままですと、全部のセルが判定対象ですが、本当は
判定が必要なセル範囲を限定させた方が良いでしょうね。

次行以下をシートモジュールに貼り付けて下さい。

Private Sub Worksheet_Change(ByVal Target As Range)

　　Dim strGroup(5) As String
　　Dim idxGroup(5) As Long
　　Dim aryTmp　　　As Variant
　　Dim lngColorIdx As Long
　　Dim rngCell　　 As Range
　　Dim i As Long, j As Long

　　'ここを書き換えて下さい===========================
　　'strGroup と idxGroup は2つで1セット
　　strGroup(0) = "会社01,会社02,会社03,会社04,会社05"
　　idxGroup(0) = 3　'赤
　　strGroup(1) = "会社06,会社07,会社08,会社09,会社10"
　　idxGroup(1) = 5　'青
　　strGroup(2) = "会社11,会社12,会社13,会社14,会社15"
　　idxGroup(2) = 46 'オレンジ
　　strGroup(3) = "会社16,会社17,会社18,会社19,会社20"
　　idxGroup(3) = 13 '紫
　　strGroup(4) = "会社21,会社22,会社23,会社24,会社25"
　　idxGroup(4) = 9　'茶
　　strGroup(5) = "会社26,会社27,会社28,会社29,会社30"
　　idxGroup(5) = 10 '緑
　　'==================================================

　　'ディフォルトフォント色
　　lngColorIdx = 0
　　Application.ScreenUpdating = False
　　'Target が複数セルでもループして処理
　　For Each rngCell In Target
　　　　'グループ数だけループ
　　　　For i = 0 To UBound(strGroup)
　　　　　　'strGroup(i)を配列にバラす
　　　　　　aryTmp = Split(strGroup(i), ",")
　　　　　　'Target.Value と比較
　　　　　　For j = 0 To UBound(aryTmp)
　　　　　　　　If Trim$(rngCell.Value) = aryTmp(j) Then
　　　　　　　　　　'一致したらidxGroup(i)がフォント色
　　　　　　　　　　lngColorIdx = idxGroup(i)
　　　　　　　　End If
　　　　　　Next j
　　　　　　Erase aryTmp
　　　　Next i
　　　　'フォント色変更
　　　　rngCell.Font.ColorIndex = lngColorIdx
　　Next rngCell

End Sub

お礼

詳しい回答をどうもありがとうございます。
参考にさせていただいて、無事に作成ができました。