Private Subについて教えてください

質問

こんにちは。
マクロ初心者です。

現在マクロを書いていて、ちょっと困ったことがありました。
初心者なのでネットで調べたり、以前こちらにも質問させて頂いたりしてやっと出来たのですが・・・。

現在やりたいことはSheet2に数字を入れるとSheet1のセルの色が変わるようにしています。
1～15までの数字にそれぞれカラー設定して数字を入力すると思ったようにSheet1のセルの色が変わるのですが、今後使用していくにあたって
データを値貼り付けするということです。

値貼り付けだとマクロが走りません。
何か良い方法はありますか？

ちなみにこちらが問題のマクロです。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim IColor As Integer
Dim R As Range
For Each R In Target
Select Case R
Case "1"
IColor = 56
Case "2"
IColor = 16
Case "3"
IColor = 13
Case "4"
IColor = 39
Case "5"
IColor = 17
Case "6"
IColor = 37
Case "7"
IColor = 41
Case "8"
IColor = 11
Case "9"
IColor = 10
Case "10"
IColor = 4
Case "11"
IColor = 6
Case "12"
IColor = 46
Case "13"
IColor = 40
Case "14"
IColor = 22
Case "15"
IColor = 26
Case Is >= 16
IColor = 3
End Select

Next
i = Target.Row
Worksheets("Sheet1").Range("B3:F7").Cells(i - 3).Interior.ColorIndex = IColor
End Sub

モジュールですとマクロ実行で走りますが、Private Subの場合で値貼り付けで走る方法などありますか？

また、もし書いたマクロが違うようであれば手直しなど一緒にして頂けると助かります。

どなたか詳しい方宜しくお願い致します。

回答No.10

Wendy02

本当に、たびたびすみません。

出来たと思った瞬間に、気が緩んでしまいました。

>Elseだったところを
>ElseIf>=16Thenに直しましたがコンパイルエラーが出てしまいました。。

ElseIf i >= 16 Then
iが抜けていました。

回答No.9

Wendy02

こんばんは。

>値貼り付けした時に0の部分も色が塗られてしまうんです・・・。

失礼しました。元のコードが、

Case Is >= 16
IColor = 3

となっていましたね。それを読み落としていました。

私のコードの中の、

-----------------------------------
　ReDim ar(CellCnt - 1)
　　For Each c In Target
　　　　If c.Value <> "" Then
　　　　　　If IsNumeric(c.Value) Then
　　　　　　　　i = c.Value
-------------------------------------
の下の部分を以下のように書き換えれば良いはずです。

　If i > 0 And i < 16 Then
　　　　　　　　　　j = iColors(i - 1)
　ElseIf >= 16 Then　　'←変更
　　　　j = 3
　End If

今は、コードを動かしてはいませんが、間違いないと思っています。それで、とりあえず試してみてください。

補足

早急な対応ありがとうございます。
Elseだったところを
ElseIf>=16Thenに直しましたがコンパイルエラーが出てしまいました。。
何度もお手数をおかけして本当に心苦しいのですが、どのようにしたら良いでしょうか(/_;)

回答No.8

Wendy02

こんばんは。

確約を取らずに作ってしまいました。
2点の、それぞれのセルの色が変わること。3列を埋めるけれども、3列に満たない場合は、途中で終わるという考え方です。以下のコードからダウンサイジングは簡単です。

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim iColors As Variant
　　Dim rw As Long
　　Dim CellCnt As Integer
　　Dim col As Integer
　　Dim col2 As Integer
　　Dim i As Integer
　　Dim j As Integer
　　Dim k As Integer
　　Dim c As Variant
　　Dim ar() As Variant
　　Dim Sh1 As Worksheet
　　Set Sh1 = Worksheets("Sheet1")
　　col = Target.Cells(1).Column
　　'制限された列
　　If Not (col = 2 Or col = 5 Or col = 8 Or col = 11) Then Exit Sub
　　iColors = Array(56, 16, 13, 39, 17, 37, 41, 11, 10, 4, 6, 46, 40, 22, 26)
　　CellCnt = Target.Count
　　ReDim ar(CellCnt - 1)
　　For Each c In Target
　　　　If c.Value <> "" Then
　　　　　　If IsNumeric(c.Value) Then
　　　　　　　　i = c.Value
　　　　　　　　If i > 0 And i < 16 Then
　　　　　　　　　　j = iColors(i - 1)
　　　　　　　　Else
　　　　　　　　　　j = 3
　　　　　　　　End If
　　　　　　　　ar(k) = j
　　　　　　　　k = k + 1
　　　　　　End If
　　　　End If
　　 Next c
　　rw = Target.Row
　　Select Case col
　　　Case 2: col2 = 1
　　　Case 5: col2 = 5
　　　Case 8: col2 = 9
　　　Case 11: col2 = 13
　　　 'Sh1.Cells(rw + 2, 13).Resize(Int(Target.Count / 3), 3).Interior.ColorIndex = j
　　End Select
　　　InsideColors Sh1, rw, col2, CellCnt, ar()

　　Set Sh1 = Nothing
End Sub
Private Sub InsideColors(sh As Worksheet, _
　　　　　　　　　　　　　rw As Long, _
　　　　　　　　　　　　　col As Integer, _
　　　　　　　　　　　　　cnt As Integer, _
　　　　　　　　　　　　　ar As Variant)
'sh[シート],rw[行], col[列],cnt[セル個数],iColor[色指数]
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim k As Integer
　If cnt Mod 3 > 0 Then　'範囲行数
　　i = (cnt + 3 - (cnt Mod 3)) / 3
　Else
　　i = cnt / 3
　End If
　rw = Int((rw - 1) / 3) + 1 '行再設定
　j = ((rw - 1) Mod 3) + 1 '列設定
　 For n = j To cnt
　　 sh.Cells(rw + 2, col).Resize(i, 3).Cells(n).Interior.ColorIndex = ar(k)
　　 k = k + 1
　 Next n
End Sub

お礼

ご連絡が遅くなりすみません。
やりたいことを完璧に理解してくださり、また完璧なコードを書いていただきましてありがとうございます☆

本当に感謝しています。ありがとうございました。
メールでしかお礼を言えないのが残念なくらいです。。
明日会社へ行って早速試してみます。

補足

こんばんは。
マクロありがとうございました。

完璧に動いて感動ものです。
ただ、一点今日気づいたのですがSheet2へ値貼り付けするとSheet1のセルがそれぞれ色が変わりますよね？

Sheet2のA1：A9へ値貼り付けした際に
A1＝1
A2＝3
A3＝4
A4＝0
A5＝0
A6＝2
A7＝1
A8＝0
A9＝1
と値貼り付けした時に0の部分も色が塗られてしまうんです・・・。
自分でも何とかしようと頑張ってみたのですが、イマイチ分からず。。。
何度も申し訳ないのですが、このような場合頂いたマクロをどのように書き換えればいいのでしょう(;_;)

回答No.7

Wendy02

こんにちは。

補足を読みました。発想がユニークで、とても面白いです。
ただ、これは、ちょっと、ひとひねり考えないといけませんね。もし、私の予想があっていれば、これは簡単ではありませんね。

コードを書いてみて、2点ほどが疑問に残りました。

・それぞれのセルは別々の色が付くのではありませんか？

・それと、もしかしたら、セルの枡を一つずつ埋めていくというものではないでしょうか？

つまり、こういうことです。

>Sheet2のB1：B9に値貼り付けをするとSheet1のA3：C5の色が変更

この場合は、9個のセルだから、3 × 3 が成立しますが、
8個の場合は、A3 ～B5 の8セル？

　A3　B3　C3
　A4　B4　C4
　A5　B5

8個だと、4角形になりません。

それで、次に、
>Sheet2のB1：B9に値貼り付けをするとSheet1のA3：C5の色が変更
この後に、B10 以降に貼り付けると、Sheet1のC5 に入るという考え方ではないでしょうか？

そんな気がしました。こういう考え方であっているのでしょうか？
今は、こんなことを考えながら進めています。たとえ間違えていても、ここから、レベルダウンするのは楽です。

回答No.6

Wendy02

とりあえず、
>頂いた回答によるとこれでは全体のマクロ構成が違うとの事ですが最初から書き直しでしょうか(;_;)

#全体のマクロの構成自体が違います。
と書いたのは、最後にあるコードが先になるのではないか、と考えたからです。コード自体が別になることではありません。

今回補足でいただいたものを元に何とか、最後までやってみるつもりです。それに、もう一人の回答者の方もいらっしゃることだし、どちらかが先に、iokmuoytさんの満足いけるものが出来れば、それで良いと思います。少し、時間をください。

お礼

何度も本当にすみません。
親身になって頂きとても感謝しております。

お任せで申し訳ありませんが、宜しくお願い致します。

回答No.5

Wendy02

こんにちは。
#3 の回答者です。
これは、私のところでも、前の#4さんのところに補足しても、質問のポイントは同じですから、どちらでもよいのですが……。

>例えばG1は反映できるのですが、G2とG3も反映させるのは
>どうのようにしたら良いでしょうか？

（^^;、やっぱり! 最初のコードをみて最初からヘンだと思っていたのです。それと、まだヘンな部分がありますね。

実際に、

Worksheets("Sheet1").Range("B3:F7").Cells(i - 3)

というのは、このコードは、1個のセルを塗るということですが、それも、奇妙にも横に動いています。

こういう説明は出来ませんか？

Sheet2 のB3:B5 まで、貼り付けたときに、
Sheet1 のA1:A3 まで、色が塗られるとか。

それから、
"B3:F7"や"G3:H10"　というのも、本当は良く分からないのです。

それは、Sheet2 自体の範囲制限、または、Sheet1 自体のイベント・ドリブンの範囲制限ではありませんか？そうすると、全体のマクロの構成自体が違います。

>例えばG1は反映できるのですが、G2とG3も反映させるのは

絵は、横になっていますが、実際は、G1,G2,G3 は、行数ですから、縦です。
こんなところをクリアしていただければ、マクロは完成するはずです。

補足

再度ご回答頂きましてありがとうございます。
説明が不十分で申し訳ありません。。。
一からきちんと説明しますと、G1～G4という項目があります。

例えば
Sheet2：A列にはG1というグループの施設名9行が入っており、B列に毎月外部から取ってくるデータG1の施設に対するデータを値貼り付けします。
D列にはG2というグループ施設名が15行ありE列は同様外部データを値貼り付け、ということなので
G1：A～B、G2：D～E、G3：G～H、G4：J～K
の列を必要とし、行は項目（G1～G4）によって違います。

外部データをSheet2のB・E・H・Kに値貼り付けすることにより
Sheet1のセルの色を変えたかったのですが
Sheet1はG1が9行あれば3×3のA3：C5の枠を取っています。
G2が15行であれば、3×5のE3：G7でセル設定をしています。

＃3の方と＃2の方のマクロを参考に値貼り付けまでは完ぺきに出来たのですが、色がつくのはG1の枠のみだけでした。

Sheet2のB1：B9に値貼り付けをするとSheet1のA3：C5の色が変更
Sheet2のE1：E15に値貼り付けをするとSheet1のE3：G7の色が変更
Sheet2のH1：H10に値貼り付けをするとSheet1のI3：K6の色が変更
Sheet2のK1：K6に値貼り付けをするとSheet1のM3：O4の色が変更

これが最終的にやりたかったことですが、全く分からなかったので
一つずつ解決していこうと思っていましが。。。

頂いた回答によるとこれでは全体のマクロ構成が違うとの事ですが
最初から書き直しでしょうか(;_;)

回答No.4

fumufumu_2006

ANo.2です。
ちゃんとfor each r in targetになっているのに、色を変える部分がfor each ～ next の外にあり、i=Target.Rowになっていたので、左上を一度だけになっていたのではないでしょうか。

i = Target.Row
を
i = R.Row
にして、
i = R.Row
Worksheets("Sheet1").Range("B3:F7").Cells(i - 3).Interior.ColorIndex = IColor
を
Next
の前にすれば、質問のプログラムは動くと思います。

追加の分は、Sheet1の黒丸の数がSheet2の下線の数と同じみたいですが、どうするのかがわかりません。

sheet1の
G1
●●●●
●●●●
●●●
と、sheet2の
G1
-----
-----
-----
-----
-----
-----
-----
-----
-----
-----
-----
というのは、どういう意味でしょうか?

もしかしたら動かないプログラムを載せてもらった方がわかるかもしれません。

補足

ありがとうございます。

＃3の方とこちらの方のマクロを組み合わせうまく走りました。
分かりやすく説明までして頂きありがとうございました。

前回補足させて頂いたものですが、
例えば
Sheet2：A列にはG1というグループの施設名9行が入っており、B列に毎月外部から取ってくるデータG1の施設に対するデータを値貼り付けします。
D列にはG2というグループ施設名が15行ありE列は同様外部データを値貼り付け、ということなので
G1：A～B、G2：D～E、G3：G～H、G4：J～K
の列を必要とし、行は項目（G1～G4）によって違います。

外部データをSheet2のB・E・H・Kに値貼り付けすることにより
Sheet1のセルの色を変えたかったのですが
Sheet1はG1が9行あれば3×3のA3：C5の枠を取っています。
G2が15行であれば、3×5のE3：G7でセル設定をしています。

＃3の方と＃2の方のマクロを参考に値貼り付けまでは完ぺきに出来たのですが、色がつくのはG1の枠のみだけでした。

Sheet2のB1：B9に値貼り付けをするとSheet1のA3：C5の色が変更
Sheet2のE1：E15に値貼り付けをするとSheet1のE3：G7の色が変更
Sheet2のH1：H10に値貼り付けをするとSheet1のI3：K6の色が変更
Sheet2のK1：K6に値貼り付けをするとSheet1のM3：O4の色が変更

これが最終的にやりたかったことですが、全く分からなかったので
一つずつ解決していこうと思っていましたが。。。

回答No.3

Wendy02

こんばんは。

値貼り付けで、このマクロが動かないわけではなくて、おそらく、シートモジュールが別のところに貼り付けてあったりするわけだと思います。この手のマクロを貼り付ける場合は、

画面下のシートタブの所を、右クリック－コードの表示　で、貼り付けていただかないと、意外に間違えていることが多いです。この場合は、[Sheet2]だと思います。

ただ、それはともかく、そのマクロですと、IColor を取るのは、領域の最後の貼り付けのものだけになるわけだと思います。それと、

つまり、i は、領域の先頭であって、

i = Target.Row
　Range("B3:F7").Cells(i - 3)
ですから、i >2 でないと、エラーが発生するはずです。

同じものを、私なりに考えてみました。

'-----------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim iColors As Variant
　　Dim i As Integer
　　Dim j As Integer
　　iColors = Array(56, 16, 13, 39, 17, 37, 41, 11, 10, 4, 6, 46, 40, 22, 26)
　　For Each c In Target
　　　　If c.Value <> "" Then
　　　　　　If IsNumeric(c.Value) Then
　　　　　　　　i = c.Value
　　　　　　　　If i > 0 And i < 16 Then
　　　　　　　　　　j = iColors(i - 1)
　　　　　　　　Else
　　　　　　　　　　j = 3
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　 Next c
　　i = Target.Row
　　If i > 2 And j > 0 Then
　　　　Worksheets("Sheet1").Range("B3:F7").Cells(i - 3).Interior.ColorIndex = j
　　End If
End Sub

補足

ご連絡が遅くなり申し訳ございません。

回答ありがとうございました。
とてもきれいな書き方で勉強になり感謝です☆

ただ、一つ値貼り付けではマクロが走らなかったのですが・・・。
私の説明不足でしたが、値貼り付けは複数行あり最初のセルのみ色が変わりました。
また、追加で教えて頂きたいのですが、各Sheetには一つではなく
いくつかのセルがあります。
例）

G1　　　　　G2　　　　G3
●●●●　　●●●　　●●
●●●●　　●●●　　●●　
●●●　　　●●●　　●

このようなSheet1に対してSheet2は
G1　　　　　G2　　　G3
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----
-----　　　-----
-----　　　-----
-----　　　-----
-----
-----

とSheet1のセルの分だけ行があります。
例えばG1は反映できるのですが、G2とG3も反映させるのは
どうのようにしたら良いでしょうか？

頂きましたマクロの("B3:F7")を("G3:H10")に置き換えてみましたがエラーが出ました。
Private　Subでは一枚のコードに2つはダメなのでしょうか？

度々すみませんが、ご回答宜しくお願い致します

回答No.2

fumufumu_2006

数字入力では動いているのなら、貼り付けでも動いていると思います。
ただ、複数領域を張り付けた場合、正しく動いていないんではないでしょうか?
左上の1セル分しか実行しないようになっていると思います。

Targetには、貼り付けの時は、まとめてこの領域と値が入って来るんじゃないかと思います。
Application.StatusBar = Target.Address(False, False)
を適当な所に入れて、数字や領域コピーをしてもらえれば、Targetの値がわかると思います。

p.s.
Application.StatusBar = False
をコード内かイミディエイトウインド内で実行すれば、ステータスバーの表示が元に戻ります。

お礼

ご回答ありがとうございます。
そうなんです。最初の値は走るんですが、複数貼り付けした場合は残りが走らないんです。。。

また、追加で申し訳ありませんが下記のように同じSheet内に
いくつかのセル設定がある場合
例）

G1　　　　　G2　　　　G3
●●●●　　●●●　　●●
●●●●　　●●●　　●●　
●●●　　　●●●　　●

このようなSheet1に対してSheet2は
G1　　　　　G2　　　G3
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----　　----
-----　　　-----
-----　　　-----
-----　　　-----
-----　　　-----
-----
-----

どのようにマクロを書いたら良いのでしょうか？
Private　Subの場合、同じコード内に同じマクロを書込みセル位置を変えてみたのですがエラーが発生しました。

度々申し訳ありませんが、ご回答お願い致します。

回答No.1

extrabold

うん？貼り付けてみたけど、イベント自体は動いているんだけど？
貼り付けた場所は、sheet1でOKかな？
イベントを拾うためには、そのイベントの対象となるシートのところに書かないといけない。標準モジュールでは駄目ですよ。

まず、「Worksheets("Sheet1").Range("B3:F7").Cells(i - 3).Interior.ColorIndex = IColor」
の、意図が読めないんだけど、
Sheet1の同じ個所に、Sheet2の結果を反映するなら、
Nextの上に、
「Worksheets("Sheet1").Cells(R.Row,R.Column).Interior.ColorIndex = IColor」とするんじゃないかな。で、NextからEndSubの間を削除。
違ってたらごめん。