エクセル２００３での条件付書式

質問

ある計算から、添付画像のような表計算が出来上がり、各グループ（１Ｇは３×４セル）に共通する数字を同色で塗りつぶしたいのですが、エクセル２００３では、条件つき書式が３条件しか設定できません。４条件以上を設定することはできますか？
　できれば自動で（数字を指定することなく）共通数字を塗りつぶしたいのですが方法はありますか？
よろしくお願いします。

回答No.2

tom04

No.1です！
ご希望通りの動きにならないみたいですね！

前提条件として
（1）前回のコード内で「Sheet2」のB列色を重複セルに表示するようにしていますので、
でSheet2のB列を適当に塗りつぶしておきます。
かなり多めの行数まで塗りつぶしておいても構いません。
（2）Sheet1の指定範囲は条件付書式の設定はないですよね？

それさえ問題なければA1～L4セルデータを変更するたびに、重複セルにSheet2のA列に重複データが表示され、
その行のB列セルの色に塗りつぶされるはずなんですが・・・

ただ、一つ気になるのは、質問の最初にある
＞ある計算から、添付画像のような表計算が出来上がり・・・
の部分です。

数式が入っていて別セルを参照しているのですかね？

もしそうであれば、前回のコードは範囲内（A1～L4）セルデータ変更時にマクロが実行される
Worksheet_Change　イベントですので、色は変化しないと思います。
（見た目は変化したようでも関数そのものが変わっていないので、データとして変化していない）

そこで今回は「再計算」されたときにマクロが実行されるコードを載せておきます。
内容はほとんど同じです。
（手抜きでごめんなさい。）

Sheet1のVBE画面を開き、前回のコードはそのままにしておいて
「End Sub」の次の行に↓のコードをコピー＆ペーストしてみてください。

Private Sub Worksheet_Calculate() 'この行から
Dim c, Rng As Range
Dim k As Long
Dim ws As Worksheet
Set Rng = Range("A1:L4")
Set ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
Rng.Interior.ColorIndex = xlNone
ws.Columns(1).Clear
For Each c In Rng
If WorksheetFunction.CountIf(ws.Columns(1), c) = 0 _
And WorksheetFunction.CountIf(Rng, c) > 1 Then
k = k + 1
ws.Cells(k, 1) = c
End If
Next c
For Each c In Rng
For k = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
If c <> "" And c = ws.Cells(k, 1) Then
c.Interior.Color = ws.Cells(k, 2).Interior.Color
End If
Next k
Next c
Application.ScreenUpdating = True
End Sub 'この行まで

※　Sheet1に二つのマクロが存在することになりますが、指定範囲内が手入力で変化しても
関数で変化しても色が表示されると思います。

今度は上手くいけば良いのですが・・・m(_ _)m

回答No.1

tom04

こんばんは！
Excel2003以前のバージョンですと、条件付書式は3条件までしか設定できませんね！

そこでVBAになってしまいますが・・・一例です。
Sheet1のA1～L4セルだけに色がつくようにしています。

↓の画像のようにSheet2を作業用のSheetとして使います。
Sheet2のB列を適当に塗りつぶしておきます。
何色でも構いません。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてA1～L4セルに適当にデータを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim c, Rng As Range
Dim k As Long
Dim ws As Worksheet
Set Rng = Range("A1:L4")
Set ws = Worksheets("Sheet2")
If Intersect(Target, Rng) Is Nothing Or Selection.Count <> 1 Then Exit Sub
Application.ScreenUpdating = False
Rng.Interior.ColorIndex = xlNone
ws.Columns(1).Clear
For Each c In Rng
If WorksheetFunction.CountIf(ws.Columns(1), c) = 0 _
And WorksheetFunction.CountIf(Rng, c) > 1 Then
k = k + 1
ws.Cells(k, 1) = c
End If
Next c
For Each c In Rng
For k = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
If c <> "" And c = ws.Cells(k, 1) Then
c.Interior.Color = ws.Cells(k, 2).Interior.Color
End If
Next k
Next c
Application.ScreenUpdating = True
End Sub 'この行まで

※　尚、条件付書式の設定があるとマクロでは塗りつぶしが出来ませんので、
範囲内の条件付書式の設定はすべて削除しておいてください。

参考になりますかね？m(_ _)m

お礼

tom04さん
　回答ありがとうございます。
私は、ほとんどＶＢＡ、マクロを使ったことがないため動かし方がおかしいのか
tom04さんが書いてくれたとおりに（新しいシートで）再現してみようと思ったのですが
うまくいきません。
コードの表示からＶＢＡワークシートにコミペだけで良いんですよね？