[[20090605114503]]　『VBAでセルに色をつけるには？』（マツ）　ページの最後に飛ぶ

『VBAでセルに色をつけるには？』（マツ）

 アルファベットのA～Oくらいまでをそれぞれ異なる色でセルを色付けをしたいのですが、
 条件付き書式では３つまでしか出来ず困っています。

 過去ログにも【３つ以上の条件でセルに色をつけるには？】があったので参照していたのですが、
 全くの初心者の為応用出来ませんでした。

 宜しくお願いします。

 参考になりませんか？
[[20050308152110]]『条件付書式の条件は３つが限度？』（よよ） 
[[20050115131721]]『条件式書式を６つやりたいんですが・・・』（sirouto）

 他にも同様の記事は結構あると思います。
 リンク先のコードはまさにマツさんが求めてるものだと思います。
 一度試してみて、分からないとこがあればお気軽にどうぞ＾＾

 (Dil)

 早々の回答ありがとうございます！
早速[[20050115131721]]『条件式書式を６つやりたいんですが・・・』（sirouto）を参照し、
 追加してやってみたんですが、【コンパイルエラー　End Subが必要です】のBOXが出てきてしまいます。
 追加したのが下記なのですが、おかしいでしょうか？
 質問ばかりですみません。

 **************************************************************************

 Sub Macro1()
 '
 ' Macro1 Macro
 ' マクロ記録日 : 2009/6/5  ユーザー名 : **

 Private Sub Worksheet_Change(ByVal Target As Range)
 '変数宣言
 Dim colr As Integer
 Dim c As Variant
 If Target.Count > 1 Then Exit Sub
 If Target.Column <> 1 Then Exit Sub
 For Each c In Target
 Select Case c.Value
 Case "A"
 colr = 34  '
 Case "B"
 colr = 36 '
 Case "C"
 colr = 38  '
 Case "D"
 colr = 35 '
 Case "E"
 colr = 45 '
 Case "F"
 colr = 39 '
 Case "G"
 colr = 15 '
 Case "H"
 colr = 33 '
 Case "I"
 colr = 26 '
 Case "J"
 colr = 50 '
 Case "K"
 colr = 6 '
 Case "L"
 colr = 3 '
 Case "M"
 colr = 46 '
 Case "N"
 colr = 23 '
 Case "O"
 colr = 22 '
 Case "P"
 colr = 43 '

 Case Else
 colr = xlNone
 End Select
 c.Interior.ColorIndex = colr
 Next c

 End Sub
 '

 こんな感じにしてくらはい。(ROUGE)
　
Private Sub Worksheet_Change(ByVal Target As Range)
Dim colr As Integer
Dim c As Range
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
For Each c In Intersect(Target, Range("A:A"))
 Select Case c.Value
  Case "A": colr = 34
  Case "B": colr = 36
  Case "C": colr = 38
  Case "D": colr = 35
  Case "E": colr = 45
  Case "F": colr = 39
  Case "G": colr = 15
  Case "H": colr = 33
  Case "I": colr = 26
  Case "J": colr = 50
  Case "K": colr = 6
  Case "L": colr = 3
  Case "M": colr = 46
  Case "N": colr = 23
  Case "O": colr = 22
  Case "P": colr = 43
  Case Else: colr = xlNone
 End Select
c.Interior.ColorIndex = colr
Next c
End Sub

 こんな感じでも？

 Private Sub Worksheet_Change(ByVal Target As Range)
 Dim myVal, myClr, r As Range, x As Long
 If Intersect(Target, Columns("a")) Is Nothing Then Exit Sub
 myVal = "ABCDEFGHIJKLMNO"
 myClr = "34363835453915332650 6 346232243"
 For Each r In Intersect(Target, Columns("a"))
     x = InStr(1,myVal, r.Value, 1)  '修正
     If x = 0 Then
         r.Interior.ColorIndex = xlNone
     Else
         r.Interior.ColorIndex = Val(Mid$(myClr, x * 2 - 1, 2))
     End If
 Next
 End Sub
 (seiya)

 ありがとうございます！
2つともチャレンジしてみたんですけど、また【コンパイルエラー】が出ました。。
根本的なやり方が間違っていますか？
初心者でほんとにすみません。。

 ****************************************************
　
Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/6/5  ユーザー名 : **
'
　
Private Sub Worksheet_Change(ByVal Target As Range)
Dim colr As Integer
Dim c As Range
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
For Each c In Intersect(Target, Range("A:A"))
 Select Case c.Value
  Case "A": colr = 34
  Case "B": colr = 36
  Case "C": colr = 38
  Case "D": colr = 35
  Case "E": colr = 45
  Case "F": colr = 39
  Case "G": colr = 15
  Case "H": colr = 33
  Case "I": colr = 26
  Case "J": colr = 50
  Case "K": colr = 6
  Case "L": colr = 3
  Case "M": colr = 46
  Case "N": colr = 23
  Case "O": colr = 22
  Case "P": colr = 43
  Case Else: colr = xlNone
 End Select
c.Interior.ColorIndex = colr
Next c
End Sub

 *************************************************

 　
Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/6/5  ユーザー名 : **
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim myVal, myClr, r As Range, x As Long
 If Intersect(Target, Columns("a")) Is Nothing Then Exit Sub
 myVal = "ABCDEFGHIJKLMNO"
 myClr = "34363835453915332650 6 346232243"
 For Each r In Intersect(Target, Columns("a"))
     x = InStr(1,myVal, r.Value, 1)  '修正
     If x = 0 Then
         r.Interior.ColorIndex = xlNone
     Else
         r.Interior.ColorIndex = Val(Mid$(myClr, x * 2 - 1, 2))
     End If
 Next
 End Sub
　
　
一番上のSub Macro1()のところが黄色になって止まっています。
　
（マツ）

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/6/5 ユーザー名 : **

Private Sub Worksheet_Change(ByVal Target As Range)

 サブは２つもいりませんよ（dack）

 1) 今あるコードを削除する
 2) シート見出しを右クリックして [コードの表示]
 3) 右空白部分に、提示したコードを変更しないでそのまま貼り付ける。

 で、できます。
 (seiya)

 seiyaさんの↓をやってみました。【コード表示】で登録は出来るんですけど、
　ﾏｸﾛを押しても登録したものが出てきません。
　試しに記録（●のボタンのやつ）をしても登録したものが出てきませんでした。。
 *************************************************************　
 1) 今あるコードを削除する
 2) シート見出しを右クリックして [コードの表示]
 3) 右空白部分に、提示したコードを変更しないでそのまま貼り付ける。
 *************************************************************
 何かおかしいでしょうか？さっぱり分かりません。。。
（マツ）

 提示したコードはチェンジイベントが発生したときに実行されます。
 A列の値を変更してみてください。
 (seiya)

 過去ログや上記で提示されているコードは通常のマクロと違って、イベントマクロというものです。

 ある動作を行った時に(今回の場合、該当シートのどこのセルでも、編集した際に)
 エクセルがそれを感知して自動でコードを実行します。
 ご参考にどうぞ。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_130_04.html

 (Dil)

 A列の値を変更というのはどうゆうことでしょうか？？
　　　　一番初めにやり始めたときはまず●ボタンの記録を一瞬押してﾏｸﾛを１作って、
　　　　編集ボタンを押して[[20050115131721]]『条件式書式を６つやりたいんですが・・・』（sirouto）の分を
　　　　貼り付けて【さるをA】に変えて上書きしました。
　　　　その時はA列の5行目以降のAと入ったセルは赤く色づけされたので、
　　　　続いてクマをB....C...D..という風に変えていったのですが、その際新規のｼｰﾄで新しく作りました。
　　　　その後からコンパイルエラーが出てくるようになって。。
　　　　でも一番上にあったSUB～の分を削除するようにご指摘頂いたのでやっていたのでその通りやっても　
　　　　うまくいかず、次はコード表示からの作業をしてみたら登録したﾏｸﾛが出てこず、、
　
　　　　知識が無いので一から教えて頂けると助かります。。
　　　　ちなみにA～Pのアルファベットのセルに色づけするのはA列だけでなく、
　　　　ｼｰﾄ全体にかけたいのですが、、
　　　　うまくいかず困っています。。。。。
　　　　
　　　　（マツ）

 条件付書式と同じような動作が必要なのですよね？
 A列の値に変化（数式を使用しないで）が生じた場合を想定しているので
 そのようなコードになるのです。

 下記は自分で実行してください。

 Sub test()
 Dim myVal, myClr, r As Range, x As Long
 myVal = "ABCDEFGHIJKLMNO"
 myClr = "34363835453915332650 6 346232243"
 For Each r In ActiveSheet.UsedRange
     x = InStr(1,myVal, r.Value, 1)  '修正
     If x = 0 Then
         r.Interior.ColorIndex = xlNone
     Else
         r.Interior.ColorIndex = Val(Mid$(myClr, x * 2 - 1, 2))
     End If
 Next
 End Sub
 (seiya)

 追記：
 質問はしっかり回答者が理解できるようにしましょう。

 seiyaさんの分をコピーしたらﾏｸﾛボタンにTESTと現れました！
　　　　ありがとうございます。
　　　　ただ、別のｼｰﾄのA列などに試しにABCDEF...と入力しておいて
　　　　TESTのﾏｸﾛを使っても色が変わらないのですが、これは何か変更しないと
　　　　いけないのでしょうか？
　　　　（ｼｰﾄ全体にﾏｸﾛがかかるようにはなってますか？？）
　
　　　　また、先ほどの質問分はややこしくてすみませんでした。。
　　　　どの手順が間違っているのか見てもらおうと思ったのですが・・・
　
　　　　（マツ）

 ActiveSheetが対象なので、選択されているシートにしか実行されません。

 これは「条件付書式」とは別物だし...
 何をどうしたときに、何をどうしたいのでしょう？

 > （ｼｰﾄ全体にﾏｸﾛがかかるようにはなってますか？？）
 意味がわかりません。
 (seiya)

 いつもは手作業を記録させるﾏｸﾛを使用していました。
 　　　　（１つのエクセルシートにﾏｸﾛを登録しておいて、別のｴｸｾﾙｼｰﾄを開き
 　　　　　そのｼｰﾄ上でﾏｸﾛを使用するというやり方です。）
 　　　　なので、ﾏｸﾛを記録したｼｰﾄ上では作業することはありませんでした。
 　　　　複数のｴｸｾﾙに同じ作業をしなければいけないので・・

 　　　　今回も同じようにしたかったのですが、条件付書式が３つまでしか登録出来ないということで
 　　　　手作業では限界があり、質問させていただきました。
 　
 　　　　やりたいのはｴｸｾﾙのｼｰﾄの全体（A列だけでなく、B列、C列。。）にアルファベットが登録してあるのでセルを色付け
 　　　　をしたいと思いました。
 　　　　それはｼｰﾄ毎に登録してあるアルファベットの位置が固定では無い為、ｼｰﾄ全体に色がつくように
 　　　　ﾏｸﾛを組めたら。。ということです。
 　
 　　　　手作業なら、まずCtrl+Aでｼｰﾄ全選択をし、条件付書式で【セルの値が⇒次の値に等しい⇒A（ﾊﾟﾀｰﾝで色付け）】
 　　　　という具合にしているものを全部で15こしたいのです。

 　　　　無理ならすみません。。
 　　　　諦めます。。
 　　　　　
 　　　　（マツ）

 全てのシートを対象にする
 ということですか？

 Sub test()
 Dim ws As Worksheet, myVal, myClr, r As Range, x As Long
 myVal = "ABCDEFGHIJKLMNO"
 myClr = "34363835453915332650 6 346232243"
 For Each ws In Sheets
     For Each r In ws.UsedRange
         x = InStr(1,myVal, r.Value, 1)  '修正
         If x = 0 Then
             r.Interior.ColorIndex = xlNone
         Else
             r.Interior.ColorIndex = Val(Mid$(myClr, x * 2 - 1, 2))
         End If
     Next
 Next
 End Sub
 (seiya)

 基本的な部分で混乱されているようですので、一応もう一度書きます。
 通常のマクロですと、ツール→マクロから好きなタイミングで手動で実行できますね？
 seiyaさんが最後に提示したものはそれですが、それ以外のコードは全てイベントマクロです。

 これは上記で書いた通り、何らかの動作(セルの編集等)を行った時に、
 エクセルがその都度自動的にマクロを実行するというものです。

 >登録したﾏｸﾛが出てこず
 このイベントマクロは、ツール→マクロとしても出てきません。
 手動で実行する物ではないので。（上の投稿とリンクを見て頂ければ分かるかと思います）

 Private Sub Worksheet_Change(ByVal Target As Range) ←この記述が
 Sub ←の代わりだと考えて下さい。

 先ほどはこの２つを同時に一箇所に記述してましたので、コンパイルエラーとなります。

 コードを記述する箇所も、標準モジュールではなくシートモジュールです。
 （今件の場合は）

 シートタブを右クリック→コードの表示として現れたモジュールがシートモジュールです。
 ここに最初のほうのコードを記述する事で、そのシートに対して何らかの編集を行った時に
 書き込んだコードが自動で実行されます。

 で、seiyaさ～ん
 >TESTのﾏｸﾛを使っても色が変わらないのですが

 x = InStr(1,r.Value ,myVal , 1)

 r.Value と myVal は逆ですよね？
 それと、r.Value が Empty値の時にも色が塗られてしまいます。。

 (Dil)

 >  x = InStr(1,r.Value ,myVal , 1) 
 おっと、大変な記載ミスです。すぐ訂正します。
 ありがとうございます。

 ちなみに、Function/Private Sub procedure はマクロ実行画面に出てきません。
           ^^^^^^^  ^^^^^^^^^^^
 マツさん
 すみませんでした、コードを変更しましたので試してください。
 (seiya)

 Dilさん、細かく説明して頂きありがとうございます。
　　　　ということは、イベントマクロは作業するシート全てにシートモジュールとして
　　　　登録しなければいけないということですね。
　　　　それは作業するシートが膨大になるので難しそうです。。
　　　　マクロは奥が深いですね。。

　　　　seiyaさんもたくさんの回答ありがとうございます！
　　　　試してみました！
　　　　空白がAと同じ色になって、Pに色がつきませんでした。。

　　　　
　　　　（マツ）

 Sub test()
 Dim ws As Worksheet, myVal, myClr, r As Range, x As Long
 myVal = "ABCDEFGHIJKLMNOP" '<- 変更
 myClr = "34363835453915332650 6 346232243"
 For Each ws In Sheets
     For Each r In ws.UsedRange
         x = InStr(1,myVal, r.Value, 1) 
         If (r.Value = "") + (x = 0) Then  '修正
             r.Interior.ColorIndex = xlNone
         Else
             r.Interior.ColorIndex = Val(Mid$(myClr, x * 2 - 1, 2))
         End If
     Next
 Next
 End Sub
 (seiya)

 お返事遅くなりすみません！
 今seiyaさんに直していただいたものを試しました！
 Pも色がつき、空白はつきませんでした。
 これで明日から活用出来ます。
 seiyaさん、初心者の私に何度も回答して下さり本当にありがとうございました。！
 とても助かりました。

 （マツ）06/05(金)21:22

 マツさん
 私のミスで余計な手間がかかってしまって、すみませんでした。
 (seiya)

コメント返信：

[ 一覧(最新更新順) ]

[[20090605114503]] 『VBAでセルに色をつけるには？』（マツ） ページの最後に飛ぶ

[[20090605114503]]　『VBAでセルに色をつけるには？』（マツ）　ページの最後に飛ぶ