Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9323 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【27986】セルの色が、入力した数字に相当する色に... bridgesbook 05/8/25(木) 22:51

【27987】Re:セルの色が、入力した数字に相当する色... とまと 05/8/25(木) 23:13

【27988】Re:セルの色が、入力した数字に相当する色... ichinose 05/8/25(木) 23:13

【27991】Re:セルの色が、入力した数字に相当する色... kobasan 05/8/25(木) 23:51

【27993】Re:セルの色が、入力した数字に相当する色... kobasan 05/8/26(金) 0:10

【27994】Re:セルの色が、入力した数字に相当する... ponpon 05/8/26(金) 0:55

【27995】Re:セルの色が、入力した数字に相当する... ichinose 05/8/26(金) 0:59

【27996】Re:セルの色が、入力した数字に相当する... ponpon 05/8/26(金) 1:25

【27997】Re:セルの色が、入力した数字に相当する... kobasan 05/8/26(金) 1:27

【27998】Re:セルの色が、入力した数字に相当する... bridgesbook 05/8/26(金) 6:43

【27999】Re:セルの色が、入力した数字に相当する... [名前なし] 05/8/26(金) 6:51

【28000】Re:セルの色が、入力した数字に相当する... [名前なし] 05/8/26(金) 6:53

【28003】Re:セルの色が、入力した数字に相当する... kobasan 05/8/26(金) 7:47

【28026】Re:セルの色が、入力した数字に相当する... bridgesbook 05/8/26(金) 18:53

【28030】Re:セルの色が、入力した数字に相当する... bridgesbook 05/8/26(金) 20:40

【28033】ミスが入り込んでいるので、修正してくだ... kobasan 05/8/26(金) 21:56


	【27986】セルの色が、入力した数字に相当する色に...

bridgesbook - 05/8/25(木) 22:51 -


	引用なし

	パスワード

こんばんわ。

セルに数字を入力すると、セルの色が、入力した数字に相当する色に変わる。
番号を消去するとセル色が無色になる。
というコードを作成しました。

１つ１つ数字を入力する場合は、正常に動くのですが、
複数セルをコピー＆ペーストすると、全てのセルが一番上の数字の色になってしまいます。
複数セルをコピー＆ペーストしても、それぞれのセルの数字に相当する色にするにはどうしたら良いのでしょうか？
なにとぞ、よろしくお願いいたします。

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

Private rT As Range

Private Sub Worksheet_Change(ByVal Target As Range)
　　Set rT = Target
　　
　　With rT
　　　　If Not Application.Intersect(rT, Range(Cells(1, 1), Cells(50, 1))) Is Nothing Then
　　　　Application.EnableEvents = False
　　　　　　.Interior.ColorIndex = .Value 'セル色を入力した値とする

　　　　　　If IsEmpty(.Value) Then '空欄なら無色とする
　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　End If
　　　　Application.EnableEvents = True
　　　　End If
　　End With
End Sub


	【27987】Re:セルの色が、入力した数字に相当する...

とまと - 05/8/25(木) 23:13 -


	引用なし

	パスワード

こんばんは。
こんなかんじでできました。

Private rT As Range

Private Sub Worksheet_Change(ByVal Target As Range)
　Set rT = Target
　Dim r As Range

If Not Application.Intersect(rT, Range(Cells(1, 1), Cells(50, 1))) Is Nothing Then
　　For Each r In rT
　　　　Application.EnableEvents = False
　　　　　　r.Interior.ColorIndex = r.Value 'セル色を入力した値とする

　　　　　　If IsEmpty(r.Value) Then '空欄なら無色とする
　　　　　　　　r.Interior.ColorIndex = xlNone
　　　　　　End If
　　　　Application.EnableEvents = True
　　Next
End If
　
End Sub


	【27988】Re:セルの色が、入力した数字に相当する...

ichinose - 05/8/25(木) 23:13 -


	引用なし

	パスワード

▼bridgesbook さん：
こんばんは。
>
>セルに数字を入力すると、セルの色が、入力した数字に相当する色に変わる。
>番号を消去するとセル色が無色になる。
>というコードを作成しました。
>
>１つ１つ数字を入力する場合は、正常に動くのですが、
>複数セルをコピー＆ペーストすると、全てのセルが一番上の数字の色になってしまいます。
>複数セルをコピー＆ペーストしても、それぞれのセルの数字に相当する色にするにはどうしたら良いのでしょうか？
>なにとぞ、よろしくお願いいたします。
>
>-------------------------------------------------------------
>
'===================================================
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim crng As Range
　　Dim rt As Range
　　Set rt = Application.Intersect(Target, Range(Cells(1, 1), Cells(50, 1)))
　　If Not rt Is Nothing Then
　　　 Application.EnableEvents = False
　　　 For Each crng In rt
　　　　　 With crng
　　　　　　 .Interior.ColorIndex = .Value 'セル色を入力した値とする
　　　　　　 If IsEmpty(.Value) Then '空欄なら無色とする
　　　　　　　　.Interior.ColorIndex = xlNone
　　　　　　　　End If
　　　　　　 End With
　　　　　 Next
　　　 Application.EnableEvents = True
　　　 End If
End Sub

これで試してみて下さい


	【27991】Re:セルの色が、入力した数字に相当する...

kobasan - 05/8/25(木) 23:51 -


	引用なし

	パスワード

▼bridgesbook さんとまとさん　ichinoseさん　今晩は。
'
'Application.EnableEvents は無くてもいいみたいです。
'Select Case でやってみてみました。
意外とシンプルにできたと思いますのでのせてみます。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
　　If (Application.Intersect(Target, Range("A1:A50")) Is Nothing) Then Exit Sub
　　For Each r In Target
　　　　Select Case r.Value
　　　　　　Case "": r.Interior.ColorIndex = xlNone '空欄なら無色
　　　　　　Case Else: r.Interior.ColorIndex = r.Value　'着色
　　　 End Select
　　Next
End Sub


	【27993】Re:セルの色が、入力した数字に相当する...

kobasan - 05/8/26(金) 0:10 -


	引用なし

	パスワード

'追加です。

>　　If IsEmpty(.Value) Then '空欄なら無色とする

'IsEmpty(.Value) は使わない方がいいと思います。
'Target.value="" の方がいいと思います。
'文字を入れたときエラーがでるので。


	【27994】Re:セルの色が、入力した数字に相当する...

ponpon - 05/8/26(金) 0:55 -


	引用なし

	パスワード

こんばんは。みなさん

文字列の時と１未満、５７以上の時は、xlnone
がいるのでは？

とまとさんのは、
　　　　　
　　　With　r
　　　　If IsEmpty(.Value) Or Val(.Value) > 56 Or Val(.Value) < 1 Or IsNumeric(.Value) = False Then
　　　　'空欄、セルの値が１未満、５７以上、数字でないなら無色とする
　　　　　　.Interior.ColorIndex = xlNone
　　　　Else
　　　　　　.Interior.ColorIndex = .Value 'セル色を入力した値とする
　　　　End If
　　　End With

ichnoseさんのは、
　　　　　　
　　　　　 With crng
　　　　　　 If IsEmpty(.Value) Or Val(.Value) > 56 Or Val(.Value) < 1 Or IsNumeric(.Value) = False Then
　　　　　　　 '空欄、セルの値が１未満、５７以上、数字でないなら無色とする
　　　　　　　 .Interior.ColorIndex = xlNone
　　　　　　 Else
　　　　　　　 .Interior.ColorIndex = .Value 'セル色を入力した値とする
　　　　　　 End If
　　　　　 End With

kobasanさんのは、
　　　　Select Case r.Value
　　　　　　Case "", Is > 56, Is < 1: r.Interior.ColorIndex = xlNone　'空欄セルの値が１未満、５７以上なら無色
　　　　　　Case Else: r.Interior.ColorIndex = r.Value　'着色
　　　 End Select

とすればどうでしょう？

そんなこと言っていたら、小数の時もあるな？　　int？？？


	【27995】Re:セルの色が、入力した数字に相当する...

ichinose - 05/8/26(金) 0:59 -


	引用なし

	パスワード

こんばんは。
エラー処理まで真剣に考えてませんでしたが、
実際には当然必要ですよね！！
私は、面倒な場合は即　On Errorですけどね・・。

ということで、書き直しました。

'======================================
Private Sub Worksheet_Change(ByVal Target As Range)
　　On Error Resume Next
　　Dim crng As Range
　　For Each crng In Application.Intersect(Target, Range(Cells(1, 1), Cells(50, 1)))
　　　 With crng
　　　　　.Interior.ColorIndex = Val(.Value) 'セル色を入力した値とする
　　　　　End With
　　　 Next
　　On Error GoTo 0
End Sub

これ要点は、処理をするセル範囲（A1～A50）にデータが入力されたら
その範囲だけ処理をするというところだったんですが・・。

尚、ご指摘よりApplication.EnableEventsは、削除しましたが、
実際には私はChangeイべントでは付けておく事が多いです。
（付けておいても影響は余りないですが、つけ忘れてセルに値を入れるコードを
追加したりするとすぐ影響がでるので・・）。


	【27996】Re:セルの色が、入力した数字に相当する...

ponpon - 05/8/26(金) 1:25 -


	引用なし

	パスワード

こんばんは。
私は、エラー処理が苦手で　というより　どんなエラーが起きるか予見できないのです。
最近は、どんなエラーがあるかいろいろと悩んで混乱しています。

On Error Resume Next
　　処理
On Error GoTo 0

この２行ですむとは・・・( -_-)


	【27997】Re:セルの色が、入力した数字に相当する...

kobasan - 05/8/26(金) 1:27 -


	引用なし

	パスワード

みなさん今晩は

エラーのことに気がついて、書いたら、自分のコードにもまだエラーが残っていている
のに気がついて、いろいろやっているうちに夜更かししている。まずいまずい。

それで見たら、みなさんがいろいろ書かれていて、もう書く必要が無くなってしまいました。

>私は、面倒な場合は即　On Errorですけどね・・。
>　　On Error Resume Next
>　　On Error GoTo 0

これが簡単でいいですね。

>これ要点は、処理をするセル範囲（A1～A50）にデータが入力されたら
>その範囲だけ処理をするというところだったんですが・・。

そうだと思います。

いろいろ考えているうちに、エラー処理は任せてもいいかなとちらちら思ったりもしました。自分で考える部分が残っている方がいいことかもしれない。？？？


	【27998】Re:セルの色が、入力した数字に相当する...

bridgesbook - 05/8/26(金) 6:43 -


	引用なし

	パスワード

bridgebookです。
皆さんありがとうございました。

これから会社に行かねばならなく、読む時間がありません。
あとでゆっくり読んで試したいと思います。
また報告させていただきます。


	【27999】Re:セルの色が、入力した数字に相当する...

[名前なし] - 05/8/26(金) 6:51 -


	引用なし

	パスワード

▼ponpon さん：
>　　　　Select Case r.Value
>　　　　　　Case "", Is > 56, Is < 1: r.Interior.ColorIndex = xlNone　'空欄セルの値が１未満、５７以上なら無色
>　　　　　　Case Else: r.Interior.ColorIndex = r.Value　'着色
>　　　 End Select
>
>とすればどうでしょう？
>
>そんなこと言っていたら、小数の時もあるな？　　int？？？

　　Select Case r.Value
　　Case 1 To 56
　　　　r.Interior.ColorIndex = Target.Value
　　Case Else
　　　　r.Interior.ColorIndex = xlNone
　　End Select

とすればいいのではないでしょうか？


	【28000】Re:セルの色が、入力した数字に相当する...

[名前なし] - 05/8/26(金) 6:53 -


	引用なし

	パスワード

Target.Valueで試してたので直し忘れ。

　　　　r.Interior.ColorIndex = Target.Value

　　　　　　　　　↓

　　　　r.Interior.ColorIndex = r.Value


	【28003】Re:セルの色が、入力した数字に相当する...

kobasan - 05/8/26(金) 7:47 -


	引用なし

	パスワード

皆さんさん　おはようございます。

　Case 1 To 56

これも、シンプルで、すっきりしていて、いいですね。


	【28026】Re:セルの色が、入力した数字に相当する...

bridgesbook - 05/8/26(金) 18:53 -


	引用なし

	パスワード

無事目的のことが出来るようになりました。
いろいろな方法が可能なんだなと、勉強になりました。

この度はありがとうございました。


	【28030】Re:セルの色が、入力した数字に相当する...

bridgesbook - 05/8/26(金) 20:40 -


	引用なし

	パスワード

最終的には、

シート（セル）は保護したい。
コピーペーストの場合も、入力規則は不変としたい。
入力文字を見やすくするようfont色を変える。

を織り込み、以下のコードで落ち着きました。

ありがとうございました。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim ra As Range
　　If (Application.Intersect(Target, Range(Cells(1, 1), Cells(1, 50))) Is Nothing) Then Exit Sub
　　For Each ra In Target
　　If Application.CutCopyMode <> False Then Application.CutCopyMode = False
　　　　ActiveSheet.Unprotect
　　　　If ra.Value = "" Then
　　　　　　ra.Interior.ColorIndex = xlNone '空欄なら無色
'　　　　　　ra.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
　　　　　　ra.Font.ColorIndex = 1
　　　　Else
　　　　　　ra.Interior.ColorIndex = ra.Value　'着色
　　　　　　ra.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
　　　　　　Select Case ra.Value
　　　　　　　　Case 2, 6, 19, 20, 24, 27, 34 To 40
　　　　　　　　　　ra.Font.ColorIndex = 1
　　　　　　　　Case Else
　　　　　　　　　　ra.Font.ColorIndex = 2
　　　　　　End Select
　　　　End If
　　　　ActiveSheet.Protect
　　Next
End Sub


	【28033】ミスが入り込んでいるので、修正してくだ...

kobasan - 05/8/26(金) 21:56 -


	引用なし

	パスワード

▼bridgesbook さん今晩は。

ごめんなさい。私のミスが入り込んでいるので、修正してください。

(1)Ａ列を全て選択して消去しするとストレスを感じる動きになります。
(2)２列に渡って範囲指定して貼り付けると２列とも色が変化します。

の２点を解決するために、下記のように修正してください。

>Private Sub Worksheet_Change(ByVal Target As Range)
>
>Dim ra As Range

'============================================================ここから
Dim r As Range, 範囲 As Range

　　Set 範囲 = Application.Intersect(Target, Range("A1:A50"))
　　If 範囲 Is Nothing Then Exit Sub
　　For Each ra In 範囲
'============================================================ここまで

>　　If Application.CutCopyMode <> False Then Application.CutCopyMode = False
>　　　　ActiveSheet.Unprotect
>　　　　If ra.Value = "" Then
>　　　　　　ra.Interior.ColorIndex = xlNone '空欄なら無色
>'　　　　　　ra.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
>　　　　　　ra.Font.ColorIndex = 1
>　　　　Else
>　　　　　　ra.Interior.ColorIndex = ra.Value　'着色
>　　　　　　ra.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
>　　　　　　Select Case ra.Value
>　　　　　　　　Case 2, 6, 19, 20, 24, 27, 34 To 40
>　　　　　　　　　　ra.Font.ColorIndex = 1
>　　　　　　　　Case Else
>　　　　　　　　　　ra.Font.ColorIndex = 2
>　　　　　　End Select
>　　　　End If
>　　　　ActiveSheet.Protect
>　　Next
>End Sub


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9323 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free