コンパイルエラー「プロシージャが大きすぎます」とのエラーが出ます

質問

セルに入力する値によって、重複した場合にセルの色が変化するようにＶＢＡで記述しましたが、設定した行数が多すぎて、コンパイルエラー「プロシージャが大きすぎます」とのエラーが出ます。小さく記述するにはどの様に書いたらよいでしょうか？ご指導お願いいたします。
記述したＶＢＡは下記とおりです。約３５行ほどでエラーです。

Private Sub Worksheet_Change(ByVal Target As Range)
Set myRng = Range("B2") '２行目の設定
For Each c In myRng
If c.Value = "" Then
c.Interior.ColorIndex = 2 'B2が空白ならばセルの色を白色
ElseIf c.Value = Range("I2") Then
c.Interior.ColorIndex = 3 'B2=I2ならばセルの色を赤色
ElseIf c.Value = Range("J2") Then
c.Interior.ColorIndex = 6 'B2=J2ならばセルの色を黄色
ElseIf c.Value = Range("K2") Then
c.Interior.ColorIndex = 6 'B2=K2ならばセルの色を黄色
ElseIf c.Value = Range("L2") Then
c.Interior.ColorIndex = 8 'B2=L2ならばセルの色を青色
ElseIf c.Value = Range("M2") Then
c.Interior.ColorIndex = 8 'B2=M2ならばセルの色を青色
Else
c.Interior.ColorIndex = xINone
End If
Next c

Set myRng = Range("C2") '２行目の設定
For Each c In myRng
If c.Value = "" Then
c.Interior.ColorIndex = 2 'C2が空白ならばセルの色を白色
ElseIf c.Value = Range("I2") Then
c.Interior.ColorIndex = 6 'C2=I2ならばセルの色を黄色
ElseIf c.Value = Range("J2") Then
c.Interior.ColorIndex = 6 'C2=J2ならばセルの色を黄色
ElseIf c.Value = Range("K2") Then
c.Interior.ColorIndex = 6 'C2=K2ならばセルの色を黄色
ElseIf c.Value = Range("L2") Then
c.Interior.ColorIndex = 8 'C2=L2ならばセルの色を青色
ElseIf c.Value = Range("M2") Then
c.Interior.ColorIndex = 8 'C2=M2ならばセルの色を青色
Else
c.Interior.ColorIndex = xINone
End If
Next c

Set myRng = Range("D2") '２行目の設定
For Each c In myRng
If c.Value = "" Then
c.Interior.ColorIndex = 2 'D2が空白ならばセルの色を白色
ElseIf c.Value = Range("I2") Then
c.Interior.ColorIndex = 6 'D2=I2ならばセルの色を黄色
ElseIf c.Value = Range("J2") Then
c.Interior.ColorIndex = 6 'D2=J2ならばセルの色を黄色
ElseIf c.Value = Range("K2") Then
c.Interior.ColorIndex = 6 'D2=K2ならばセルの色を黄色
ElseIf c.Value = Range("L2") Then
c.Interior.ColorIndex = 8 'D2=L2ならばセルの色を青色
ElseIf c.Value = Range("M2") Then
c.Interior.ColorIndex = 8 'D2=M2ならばセルの色を青色
Else
c.Interior.ColorIndex = xINone
End If
Next c
　　　　　・
　　　　　・
End Sub

回答No.10

Wendy02 · ベストアンサー

こんにちは。

単に、パターンを二つ用意すればよいだけです。
2つのパターンが、3つでも同じことです。

>入力は２行目から１００行ほど使用します。
現在は、この制限は設けていません。
必要なら、
　　j = Target.Row の下に、
If j < 2 Or j >100 Then Exit Sub
を付けてください。

'------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Variant
　　Dim j As Long
　　Dim k As Variant
　　Dim Ar1 As Variant
　　Dim Ar2 As Variant
　　If Target.Count > 1 Then Exit Sub '複数セルは除外
　　j = Target.Row
　　Ar1 = Array(3, 6, 6, 8, 8) 'パターン1
　　Ar2 = Array(6, 6, 6, 8, 8) 'パターン2
　　For Each k In Array(2, 3, 4) 'B,C,D
　　　　If Cells(j, k).Value = "" Then
　　　　　　Cells(j, k).Interior.ColorIndex = 2
　　　　Else
　　　　　　i = Application.Match(Cells(j, k).Value, Range(Cells(j, 9), Cells(j, 13)), 0) 'I-M
　　　　　　If Not IsError(i) Then
　　　　　　　 If k = 2 Then
　　　　　　　　 Cells(j, k).Interior.ColorIndex = Ar1(i - 1)
　　　　　　　 Else
　　　　　　　　 Cells(j, k).Interior.ColorIndex = Ar2(i - 1)
　　　　　　　 End If
　　　　　　Else
　　　　　　　　Cells(j, k).Interior.ColorIndex = xlNone
　　　　　　End If
　　　　End If
　　Next
End Sub

お礼

ありがとうございます。
思い通りのＶＢＡです。早速使わせていただきます。

回答No.9

Wendy02

こんばんは。

最初から、条件付き書式のマクロ版と分かれば、そのように作りましたが、あまり例のないパターンだと思います。本来は、条件付き書式のマクロ版は、Change イベントでよかったのか、OnEntry を使うのか、はっきりしません。OnEntryの方が安定しているような気がしますが、どちらでも大差はないとは思います。それと、Interior.ColorIndex = 2　は、背景とか文字の色とかに依存されるので、これが発生すると枠線が消えてしまいます。

>B=I赤　　B=J黄　　B=K黄　　B=L青　　B=M青

>C=I黄　　C=J黄　　C=K黄　　C=L青　　C=M青
>D=I黄　　D=J黄　　D=K黄　　D=L青　　D=M青

C=I黄,　D=I黄　は、赤ではないでしょうか。もし、そうなら以下のようになるはずです。

----------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Variant
　　Dim j As Long
　　Dim k As Variant
　　Dim Ar As Variant
　　If Target.Count > 1 Then Exit Sub '複数セルは除外
　　j = Target.Row
　　Ar = Array(3, 6, 6, 8, 8)　'色番号
　　For Each k In Array(2, 3, 4) 'B,C,D
　　　　If Cells(j, k).Value = "" Then
　　　　　　Cells(j, k).Interior.ColorIndex = 2
　　　　Else
　　　　　　i = Application.Match(Cells(j, k).Value, Range(Cells(j, 9), Cells(j, 13)),　0) 'I-M
　　　　　　If Not IsError(i) Then
　　　　　　　　Cells(j, k).Interior.ColorIndex = Ar(i - 1)
　　　　　　Else
　　　　　　　　Cells(j, k).Interior.ColorIndex = xlNone
　　　　　　End If
　　　　End If
　　Next
End Sub

補足

追記で回答ありがとうございます。
複雑な質問で申しわけありません。
C=I　D=I　は、赤ではなく、黄色になればありがたいのですが、自分では知識不足で難航しています。

回答No.8

n-jun

＃７です。

＞今回は条件書式でクリアーできましたが、条件書式で対処できない場合に、
＞ＶＢＡで記述する方法をご教授願えれば
条件付き書式でやらないと処理がややこしくなるので提案した次第です。
よって更に条件を複雑化される場合では、私には追いつけません。
ごめんなさい。

回答No.7

n-jun

＃６です。

＞セルの色の条件がＩ列からＭ列まで５つの条件で変化するので、
＞条件付き書式では３つまでしか設定できませんので無理でした。
Ｂ列については、
・Ｉ列と同じなら、赤色　=B2=I2
・Ｊ列又はＫ列と同じなら、黄色　=OR(B2=J2,B2=K2)
・Ｌ列又はＭ列と同じなら、青色　=OR(B2=L2,B2=M2)

Ｃ・Ｄ列については、
・Ｉ列又はＪ列又はＫ列と同じなら、黄色　=OR(C2=$I2,C2=$J2,C2=$K2)
・Ｌ列又はＭ列と同じなら、青色　=OR(C2=$I2,C2=$M2)
をつける。（それ以外の場合は色はつかないはず）

と考えれば条件は３つ以内で収まるのですが、それでもダメだったのでしょうか？

参考ＵＲＬ：
3つの条件で書式を変える　＞数式で条件を設定する場合
参照願います。

参考URL：

http://www.eurus.dti.ne.jp/~yoneyama/Excel/jyo-syo.html#fukusuu

お礼

できました！　ありがとうございます。
条件書式は３つまでと思っていましたので、この様な方法があるとは考えもつきませんでした。ひとつ賢くなりました。
ついでと言っては何ですが、今回は条件書式でクリアーできましたが、条件書式で対処できない場合に、ＶＢＡで記述する方法をご教授願えれば大変ありがたいのですが、宜しくお願いいたします。

回答No.6

n-jun

＃４です。

＞逆からI2に5を入力してB2に5を入力してもB2セルが赤色になると便利なのですが
Ｉ列が変化した時にＢ列も変化させたいならば、Ｃ・Ｄ列はその時どうなるの？

＞また、入力したセルを複数選択してDeleteで消去するとエラーが出てしまいました
データ行数がどの位なのかわかりませんが、条件付き書式ではできなかったのでしょうか。

補足

知識不足で申しわけありません
各Ｂ列・Ｃ列・Ｄ列の色の変化に対する条件は、個々に独立していますので、Ｃ・Ｄ列に変化はありません。
セルの色の変化は下記のとおりです
B=I赤　　B=J黄　　B=K黄　　B=L青　　B=M青
C=I黄　　C=J黄　　C=K黄　　C=L青　　C=M青
D=I黄　　D=J黄　　D=K黄　　D=L青　　D=M青

セルの色の条件がＩ列からＭ列まで５つの条件で変化するので、条件付き書式では３つまでしか設定できませんので無理でした。

回答No.5

Wendy02

こんばんは。

少しやりたいことを解説をしてもらわないと、良く分からないです。
色を変えるのは、入力したセルのはずです。それが、Target セルです。いくらループしても、一回きりなら同じなのではありませんか？

例えば、こんな風には出来ますが、コードだけでは、意味が取り違えているかもしれません。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub '複数セルは除外
If Target.Row <> 2 Then Exit Sub　'2行目
If Target.Column < 2 Or Target.Column > 8 Then Exit Sub 'B～Hまで（排他的設定）
　　With Target
　　　　Select Case True
　　　　　　Case .Value = "": .Interior.ColorIndex = 2 'B2が空白ならばセルの色を白色
　　　　　　Case .Value = Range("I2").Value: .Interior.ColorIndex = 3 '赤色
　　　　　　Case .Value = Range("J2").Value: .Interior.ColorIndex = 6 '黄色
　　　　　　Case .Value = Range("K2").Value: .Interior.ColorIndex = 6 '黄色
　　　　　　Case .Value = Range("L2").Value: .Interior.ColorIndex = 8 '青色
　　　　　　Case .Value = Range("M2").Value: .Interior.ColorIndex = 8 '青色
　　　　　　Case Else: .Interior.ColorIndex = xlNone
　　　　End Select
　　End With
End Sub

補足

分かりづらい質問で申しわけありません。
補足しますと、Ｂ列からＤ列とＩ列からＭ列を使用します。
セルの色が値によって変わるのは、Ｂ列からＤ列です。
例えばB2に5を入力してI2に5を入力するとB2セルが赤色になり
逆からI2に5を入力してB2に5を入力してもB2セルが赤色になります
入力は２行目から１００行ほど使用します。
セルの色の変化は下記のとおりです
B=I赤　　B=J黄　　B=K黄　　B=L青　　B=M青
C=I黄　　C=J黄　　C=K黄　　C=L青　　C=M青
D=I黄　　D=J黄　　D=K黄　　D=L青　　D=M青

回答No.4

n-jun

＃１です。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Variant

With Target
If .Row < 2 Then Exit Sub '１行目は除外
If .Column > 8 Then Exit Sub 'Ａ～Ｈ列が対象
If .Value = "" Then .Interior.ColorIndex = 2: Exit Sub '空白ならばセルの色を白色

On Error Resume Next
i = Application.Match(.Value, _
Range(Range("I" & .Row), Range("M" & .Row)), 0)
If IsError(i) Then i = 0
On Error GoTo 0

Select Case i

Case 1
.Interior.ColorIndex = 3 'Ｉ列と同じなら赤色

Case 2 To 3
.Interior.ColorIndex = 6 'Ｊ・Ｋ列と同じなら黄色

Case 4 To 5
.Interior.ColorIndex = 8 'Ｌ・Ｍ列と同じなら青色

Case Else
.Interior.ColorIndex = xlNone '一致した列がなければ色なし
End Select

End With
End Sub

勘違いでしたらごめんなさい。

補足

RowとGoToを使用するのですね。
逆からI2に5を入力してB2に5を入力してもB2セルが赤色になると便利なのですが
また、入力したセルを複数選択してDeleteで消去するとエラーが出てしまいました
どうしたら良いでしょうか？

回答No.3

xls88

ElseIf c.Value = Range("I2") Then
　　c.Interior.ColorIndex = 3 'B2=I2ならばセルの色を赤色

ElseIf c.Value = Range("I2") Then
　　c.Interior.ColorIndex = 6 'C2=I2ならばセルの色を黄色

ElseIf c.Value = Range("I2") Then
　　c.Interior.ColorIndex = 6 'D2=I2ならばセルの色を黄色
上記、3か所提示されたセルで、B2のみ、ColorIndex = 3となっていますが間違いないですか？

Set myRng = Range("B2") '２行目の設定
For Each c In myRng
・
・
Next C
上記、myRngがRange("B2")のみの単独セルで、For Eachする必要はないですね。
やるなら
Set myRng = Range("B2:H2")
For Each c In myRng
　　If c.Value = "" Then
　　　　c.Interior.ColorIndex = 2　'Cが空白ならばセルの色を白色
　　ElseIf c.Value = Range("I2") Then
　　　　If c.Address = "B2" Then　'B2=I2ならばセルの色を赤色
　　　　　　c.Interior.ColorIndex = 3
　　　　Else　　　　　　　　　　　'B2以外でI2ならばセルの色を赤色
　　　　　　c.Interior.ColorIndex = 6
　　　　End If
　　ElseIf c.Value = Range("J2") Then
　　　　c.Interior.ColorIndex = 6 'C=J2ならばセルの色を黄色
　　ElseIf c.Value = Range("K2") Then
　　　　c.Interior.ColorIndex = 6 'C=K2ならばセルの色を黄色
　　ElseIf c.Value = Range("L2") Then
　　　　c.Interior.ColorIndex = 8 'C=L2ならばセルの色を青色
　　ElseIf c.Value = Range("M2") Then
　　　　c.Interior.ColorIndex = 8 'C=M2ならばセルの色を青色
　　Else
　　　　c.Interior.ColorIndex = xINone
　　End If
Next c

補足

If～ElseIfステートメントを使用しても同様な作業ができるのですね
３行目以降もセルの色の変化が必要ですのでお知恵をお貸し下さい

回答No.2

singlecat

非常に冗長的なロジックですねｗ
条件がよく解りませんが、ほぼ同様の事を繰り返す事が想像されるので、
うまくループで回して処理する事をお勧めします。

お礼

同条件で下の行へプログラムが実行されるＶＢＡがなかなか難しく
今後勉強したいと思います

回答No.1

n-jun

色をつける”範囲”と”その条件”と”結果”を提示してみては。

お礼

追記していただきありがとうございます。