Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Excel 2010)
条件付書式の色を自由に設定したい
投稿日時: 17/10/04 13:24:07
投稿者: あこりこ

条件付書式設定の色を自由に変化させたいのですが、
ツーバーの特定の条件付書式設定ではできそうにありませんので
ご質問させて頂きます。
 
▼やりたい事
シート上のセル範囲(A1:G14)の中で下記記号と
同じ文字が入力されている場合に夫々の記号に設定したカラーで塗りつぶしをしたい。
なお、記号とカラーの相関は同一シートのセル範囲(I1:J20)に入力しております。
 
I列  J列
記号 カラー
 
A  赤
B  青
C  黄
 
また現状はJ列に直接色を入れておりますが、もしこの方法では
難しいという場合はRGBを入力が必要等もご教示頂けますと幸いです。

回答
投稿日時: 17/10/04 15:29:29
投稿者: ピンク

>ツーバーの特定の条件付書式設定ではできそうにありませんので
VBAで行うのならこんな感じ
シートモジュールに貼り付けてお試しください。
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, myR As Variant
     
    For Each c In Target
        If Not Intersect(c, Range("A1:G14")) Is Nothing Then
            myR = Application.Match(c.Value, Range("I1:I20"), 0)
            If Not IsError(myR) Then
                c.Interior.Color = Cells(myR, "J").Interior.Color
            Else
                c.Interior.Color = xlColorIndexNone
            End If
        End If
    Next
End Sub

回答
投稿日時: 17/10/04 16:04:47
投稿者: WinArrow
投稿者のウェブサイトに移動

条件付き書式の設定個数は、一応、無制限なので、
20パターンくらいならば、VBAでなくても設定できると思いますが・・・
 
しかし、隣り合っているセルの色が目視でわかるのでしょうか?

投稿日時: 17/10/04 16:42:14
投稿者: あこりこ

早速ご教示頂き誠にありがとうございます。
 
下記をモジュールに貼り付けし試してみましたが、
A1:G14内の該当記号のセルに塗りつぶしが掛からない状態です。
なお、諸事情によりカラー参照先の位置を変更いたしましたが
これが起因しているのでしょうか?
なお、デバックポイント設定しプロシージャが動いている事は確認済です。
お手数お掛けいたしますが、引き続きご教示の程お願いいたします。
 
Y列  AE列
記号 カラー
  
A  赤
B  青
C  黄
 
-----------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, myR As Variant
       
     For Each c In Target
         If Not Intersect(c, Range("A1:G14")) Is Nothing Then
             myR = Application.Match(c.Value, Range("Y1:Y33"), 0)
             If Not IsError(myR) Then
                 c.Interior.Color = Cells(myR, "AE").Interior.Color
             Else
                 c.Interior.Color = xlColorIndexNone
             End If
         End If
     Next
 End Sub
-----------------------------------

投稿日時: 17/10/04 16:48:40
投稿者: あこりこ

WinArrowさん
 
ご確認いただきありがとうございます。
本来であれば条件付書式設定で収めたいところなのですが、
下記の通り記号に対するカラーをユーザが任意に設定する仕様に
しなければならないため皆様のご教示を頂きたいものです。
お手数お掛けいたしますが、どうぞ宜しくお願いいたします。
 
----------------------------
<例>Aさん
Y列  AE列
 記号 カラー
   
A  赤
B  青
C  黄
 
<例>Bさん
Y列  AE列
 記号 カラー
   
A  緑
B  白
C  赤
 

回答
投稿日時: 17/10/04 17:09:35
投稿者: WinArrow
投稿者のウェブサイトに移動

記号:Aを何色にするのかは、ユーザー(操作者)が決めるということですね?
 
それならば、了解です。
 
 
一つアドバイス
 
(1)記号と色のセル範囲について
 
セルのアドレスをコードの中に記述すると、
変更した場合、コードの修正が必要になります。
コードを極力変更しなくて済むようにセル範囲に名前を設定し、
コードの中ではその名前で記述します。
 
記号と色のセルが、離れすぎています。
対応が目視できなくなる恐れがあるので
記号セルそのものに背景色を設定してしまったらいかがでしょう。

回答
投稿日時: 17/10/04 17:24:46
投稿者: ピンク

参照先が変わればコードも変わります。
記号の書かれた範囲(Y1:Y20)に範囲名を記号と設定してください
カラーの書かれた範囲(AE1:AE20)に範囲名を記号と設定してください
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, myR As Variant
     
    For Each c In Target
        If Not Intersect(c, Range("A1:G14")) Is Nothing Then
            myR = Application.Match(c.Value, Range("記号"), 0)
            If Not IsError(myR) Then
                c.Interior.Color = Range("カラー").Item(myR).Interior.Color
            Else
                c.Interior.Color = xlColorIndexNone
            End If
        End If
    Next
End Sub
範囲名の設定の仕方は、Y1:Y20を選択し、[数式]タブの[定義された名前]グループ[名前の定義]
をクリックして行ってください。
カラー 範囲名も同じ要領で行ってください。
 

投稿日時: 17/10/04 18:03:42
投稿者: あこりこ

ピンクさん
WinArrowさん
 
お忙しい中ご教示頂きありがとうございます。
初心者故に推測となってしまうのですが、正常に動作しない理由は
下記と考えられます。
私の説明不足となり誠に申し訳ございません。
 
シート上のセル範囲(A1:G14)に表示されている記号は直接入力ではなく、
別シートに入力した値を表示されているものであるため、
ご教示頂いたプロシージャでセル範囲(A1:G14)の該当セルを
「F2」+「Enter」で指定すると任意のカラーに切り替わります。
 
そのため、下記使用環境下である事を踏まえ、追加でご教示願えませんでしょうか。
お手数お掛けいたしますが、どうぞ宜しくお願いいたします。
 
Aシート→値を入力するシート名
Bシート→値を表示させ任意のカラーを表示したいシート
 
 
 

回答
投稿日時: 17/10/04 19:22:36
投稿者: WinArrow
投稿者のウェブサイトに移動

他の回答者が回答したコードは、
いづれかのセルの値が変化(同じ値でも)した時のマクロを実行する
イベントプロシジャで記述されています。
 
マクロを組む上で大切なことは、
そのマクロをどのようなタイミングで実行するかということです。
 
あこりこさんの質問の中には、説明がなかったので、
回答者が推測してイベントプロシジャで回答したものと思います。
(条件付き書式と略同じタイミングになるため)
 
マクロを実行するタイミング
 

(1)シート上に設けたボタンを押したとき
(2)入力用シートから表示用シートに切り替えた時
(3)手操作でマクロを実行させる
 
これらは、あなたが考えることですので、どのような方法がよいか考えてみましょう。
 

回答
投稿日時: 17/10/04 20:35:08
投稿者: WinArrow
投稿者のウェブサイトに移動

別の提案
 
マクロで条件付き書式を設定する参考コード
なお、記号を入力したセルに背景色を設定する前提にしています。
 
[標準モジュール]
 
Private Type typeCOLTBL
    記号 As String
    色 As Long
End Type
 
 
Sub 条件付き書式設定マクロ()
Dim COLORTBL() As typeCOLTBL
Dim COLX As Long
Dim kigo As Range, i As Long
 
 
'名前=記号・・・J1:J20
 
    ReDim COLORTBL(0): COLX = 0
    For Each kigo In Range("記号").Cells
        If kigo.Value = "" Then Exit For
        ReDim Preserve COLORTBL(COLX)
        COLORTBL(COLX).記号 = kigo.Value
        COLORTBL(COLX).色 = kigo.Interior.Color
        COLX = COLX + 1
    Next
    With Sheets("Bシート").Range("A1:G14")
        .Select
        .FormatConditions.Delete
        For COLX = LBound(COLORTBL) To UBound(COLORTBL)
            .FormatConditions.Add _
                Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & """" & COLORTBL(COLX).記号 & """"
            .FormatConditions(COLX + 1).Interior.Color = COLORTBL(COLX).色
            .FormatConditions(COLX + 1).StopIfTrue = True
        Next
    End With
End Sub
 
なお、このマクロを実行するのは、記号テーブルを変更した時だけ実行すればよいです。
いつ実行するかは、お任せします。
 
 

投稿日時: 17/10/04 21:58:13
投稿者: あこりこ

WinArrowさん
 
遅い時間ながらご教示下さり、誠にありがとうございます。
ご教示頂きました対応方法にて正常に記号にカラーの塗りつぶしが実行できました。
しかも、条件付書式そのものを作る方法ですので、可視化できとても分かりやすいです。
本当にどうもありがとうございました。
 
なお、大変失礼ながらもう一点ご教示頂きたい点があります。
 
ご教示頂いた対応によって、元々手動で条件付設定したものが消えてしまう事から
下記条件書式設定を追加する方法をご教示頂けないでしょうか?
 
▼追加したい事
シートBのセル範囲(A1:G14)の中で「あ」or「い」or「う」の文字が入力されている場合は
フォントカラーを赤に変更する
 
お手数お掛けいたしますが、どうぞ宜しくお願いいたします。

回答
投稿日時: 17/10/04 22:42:20
投稿者: WinArrow
投稿者のウェブサイトに移動

引用:
▼追加したい事
シートBのセル範囲(A1:G14)の中で「あ」or「い」or「う」の文字が入力されている場合は
フォントカラーを赤に変更する

 
「あ」も「い」も記号と考えて
記号テーブルに追加します。
 
Private Type typeCOLTBL
    記号 As String
背景色 As Long
    文字色 As Long

End Type
   
   
Sub 条件付き書式設定マクロ()
Dim COLORTBL() As typeCOLTBL
Dim COLX As Long
Dim kigo As Range, i As Long
   
   
 '名前=記号・・・J1:J20
   
    ReDim COLORTBL(0): COLX = 0
    For Each kigo In Range("記号").Cells
        If kigo.Value = "" Then Exit For
        ReDim Preserve COLORTBL(COLX)
        COLORTBL(COLX).記号 = kigo.Value
COLORTBL(COLX).背景色 = kigo.Interior.Color
        COLORTBL(COLX).文字色 = kigo.Font.Color

        COLX = COLX + 1
    Next
    With Sheets("Bシート").Range("A1:G14")
        .Select
        .FormatConditions.Delete
        For COLX = LBound(COLORTBL) To UBound(COLORTBL)
            .FormatConditions.Add _
                 Type:=xlCellValue, Operator:=xlEqual, Formula1:="=" & """" & COLORTBL(COLX).記号 & """"
.FormatConditions(COLX + 1).Interior.Color = COLORTBL(COLX).背景色
            .FormatConditions(COLX + 1).Font.Color = COLORTBL(COLX).文字色

            .FormatConditions(COLX + 1).StopIfTrue = True
        Next
    End With
End Sub
 

投稿日時: 17/10/05 15:29:07
投稿者: あこりこ

WinArrowさん
 
早速ご教示頂きありがとうございます。
こちらで問題なく実行できました。
適切なご教示を頂き感謝いたします。
どうもありがとうございました。