エクセル（2003）で数値の入ったセルを色分けする方法とは？
- エクセル（2003）で数値の入ったセルを色分けする方法を教えてください。
- セルに数値を入力すると色が変わるが、別のところから数値をコピーペーストすると色が変わらない。
- VBAやマクロなども使用して、数値を5種類に分けてセルの色を変える方法を教えてください。
- ベストアンサー
数値の入ったセルの色分け
エクセル（2003）で数値の入ったセルを色分けしたいです。 色んなサイトを見て下記を書いてみましたが 数値を入力すると色が変わるのですが 別のところから数値をコピーペーストすると色が変わりません。 マクロでもVBAでもなんでもかまいません。 数値を5種類に分けてセルの色を変える方法を教えていただきたいです。 宜しくお願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim myNO As Integer With Target If .Count > 1 Then Exit Sub If IsEmpty(.Value) Then Exit Sub If Not Application.Intersect(Target, Range("A1:AX51")) Is Nothing Then Select Case .Value Case Is <= 54: myNO = 3 Case 55 To 79: myNO = 39 Case 80 To 104: myNO = 4 Case 105 To 119: myNO = 33 Case Is >= 120: myNO = 6 End Select .Interior.ColorIndex = myNO End If End With End Sub
- sakura1sakura1
- お礼率100% (3/3)
- Windows XP
- 回答数3
- ありがとう数3
- みんなの回答 （3）
- 専門家の回答
質問者が選んだベストアンサー
条件が5つなので条件付き書式では処理できない、 というご質問の趣旨ですね？ 現在のマクロを消して、以下のように書き換えてはいかがでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim myRange As Range For Each myRange In Selection Select Case myRange.Value Case Is <= 54 myRange.Interior.ColorIndex = 3 Case 55 To 79 myRange.Interior.ColorIndex = 39 Case 80 To 104 myRange.Interior.ColorIndex = 4 Case 105 To 119 myRange.Interior.ColorIndex = 33 Case Is >= 120 myRange.Interior.ColorIndex = 6 End Select Next End Sub
その他の回答 (2)
- mu2011
- ベストアンサー率38% (1910/4994)
>別のところから数値をコピーペーストすると色が変わりません。 ⇒問題なく色が変わりました、何か勘違いされているのではないでしょうか。 >マクロでもVBAでもなんでもかまいません。 ⇒エクセル２００３ならマクロ（ＶＢＡ）でしかできません。 複数セル範囲や色リセットを考慮しましたが如何でしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim myNO As Integer If Intersect(Target, Range("A1:AX51")) Is Nothing Then Exit Sub For Each a In Target myNO = xlNone If IsNumeric(a.Value) Then Select Case a.Value Case 1 To 54: myNO = 3 Case 55 To 79: myNO = 39 Case 80 To 104: myNO = 4 Case 105 To 119: myNO = 33 Case Is >= 120: myNO = 6 End Select End If a.Interior.ColorIndex = myNO Next End Sub
お礼
早速お返事いただきありがとうございました。 複数セルのコピーペーストが出来なかったのです。 無知なもので、書き方も不十分ですみません。 ご指導のおかげで出来るようになりました。 ありがとうございました。
- nobb_hero
- ベストアンサー率45% (9/20)
手元にExcel2003が無いのでURLへの誘導になってしまいますが Excel 2003 条件付き書式設定 http://www.geocities.jp/ogino2600x/1411.html こちらに紹介されている方法でも可能ですよ。 というか、ご質問のような事をしたいならVBA使うよりも条件付き書式の方が一般的な気がします＾＾；
お礼
早速お返事いただき、ありがとうございました。 エクセル２００３での条件付書式は3個しか設定できませんでしたので 苦戦しておりました。 ご指導いただき、ありがとうございました。
関連するQ&A
- Worksheet_Changeが動かない
エクセル自動実行のマクロを作成中にうまく動かないので サンプルをコピーして、変更してみたのですが そのサンプルも動いません、マクロとは違う何か悪いのでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim intColor As Integer If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("B2:B11")) Is Nothing Then Exit Sub Select Case Target.Value Case Is <= 20 intColor = 3 Case 21 To 40 intColor = 46 Case 41 To 60 intColor = 9 Case 61 To 80 intColor = 10 Case Is > 80 intColor = 5 End Select Target.Font.ColorIndex = intColor Application.EnableEvents = True End Sub
- ベストアンサー
- その他MS Office製品
- エクセルのマクロ
セルの値が変わったら動くマクロですが、2つ書くとエラーが出ます。 どのように直したらいいでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target.Address If Intersect(Target, Range("EK22")) Is Nothing Then Exit Sub Else Range("EK24:EM28").Select Selection.ClearContents End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("EK24")) Is Nothing Then Exit Sub Else Range("EK27:EM28").Select Selection.ClearContents End If End Sub
- ベストアンサー
- Excel（エクセル）
- 入力用のセルと管理用のセルを分けるには？？
Private Sub Worksheet_Change(ByVal Target As Range) Dim myC As String Dim x As Range If Intersect(Target, Range("A1,C2,D4")) Is Nothing Then Exit Sub Select Case Target.Address(0, 0) Case "A1": myC = "E" Case "C2": myC = "F" Case "D4": myC = "G" End Select If Cells(Rows.Count, myC).End(xlUp).Value = "" Then Set x = Cells(Rows.Count, myC).End(xlUp) Else Set x = Cells(Rows.Count, myC).End(xlUp).Offset(1) End If x.Value = Target.Value End Sub 入力用セルと、管理用のセルを分けたい・・・・・ という質問をしてこのマクロを教えていただいたんですが、 実際には入力用にしたいセルが、４０箇所以上ありまして 一つ一つ反映させるのではなく、すべての箇所に入力して確認後に まとめて反映させたいのですが不可能でしょうか？？ 何か方法があるようでしたらヨロシクお願いします！！ エクセル２００３です。
- 締切済み
- オフィス系ソフト
- 入力数値によってセル色が決まるコードで変更が正しく反映されません
セルの入力数値によってセルの塗りつぶし色が決まるコードを自作してみました。 0 =< x < 2 : 赤 2 =< x < 4 : 青 4 =< x < 6 : 黄 6 =< x < 8 : 黄緑 8 =< x < 10: ピンク それ以外 : 塗りつぶしなし なんとなくCaseの使い方が正確ではないような気もしますが。。。 ここで困ったことがおきました。手動で数字を入力すると、一応意図したとおりにセルの塗りつぶし色が反映されます。しかし、一旦塗りつぶされたセルの数値を消去しても、塗りつぶしなしとはならずに赤くなってしまいます。 また、対象外のセルから数字を一つコピーして対象セルに貼り付けると、意図したとおりに色が反映されます。しかし、二つ以上のセルをコピーして貼り付けようとすると、実行エラー'13'型が一致しません、というエラーが出てしまいます。 原因が分かりましたらご教示いただけると幸いです。 --- Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column >= 1 And Target.Column <= 10 Then If Target.Row >= 1 And Target.Row <= 10 Then Select Case Target.Value Case 0 To 2 Target.Interior.ColorIndex = 3 Case 2 To 4 Target.Interior.ColorIndex = 5 Case 4 To 6 Target.Interior.ColorIndex = 6 Case 6 To 8 Target.Interior.ColorIndex = 4 Case 8 To 10 Target.Interior.ColorIndex = 7 Case Else Target.Interior.ColorIndex = 2 End Select End If End If End Sub ---
- ベストアンサー
- Visual Basic
- エクセル イベントマクロのエラー回避
イベントマクロを初めて書いてみたのですが A列を全部選択して削除などをするとエラーがて出てしまいます 回避するにはどのようにしたら良いのでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A:A")) Is Nothing Then Select Case Target.Value Case Is = "りんご" cellColor = 3 Case Is = "みかん" cellColor = 6 End Select End If If Not Intersect(Target, Range("B:B")) Is Nothing Then Select Case Target.Value Case Is = "りんご" cellColor = 6 Case Is = "みかん" cellColor = 3 End Select End If Target.Interior.ColorIndex = cellColor End Sub 以上が書いたものです。 皆様の知恵お貸しください 宜しくお願いします。
- ベストアンサー
- オフィス系ソフト
- Worksheet_Change、名前の定義で分岐
エクセル2010です。 Worksheet_Change イベントで、名前の定義で分岐させようと思います。 下記二つの方法は思いつきましたが、ほかにもっと良い方法はないでしょうか？ 実際にはもっとたくさんの名前の定義があります。 ・Intersectで見る方法 Private Sub Worksheet_Change(ByVal Target As Range) Select Case True Case Not Application.Intersect(Target, Range("見積日")) Is Nothing Range("有効期限").Value = Range("見積日").Value + 60 Case Not Application.Intersect(Target, Range("Trigger")) Is Nothing If Target(1).Value = "AAAA" Then '(1)は結合セルクリア対策 MsgBox "BBBBを入力してください。" Range("BBBB").Select Else Range("BBBB").MergeArea.ClearContents End If Case Not Application.Intersect(Target, Range("BBBB")) Is Nothing If Target(1).Value = "日付入力" Then Range("BBBB").Value = InputBox("日付を入力してください。") End If End Select End Sub ・アドレスで見る方法 Private Sub Worksheet_Change(ByVal Target As Range) Select Case True Case Target(1).Address = Range("見積日")(1).Address Range("有効期限").Value = Range("見積日").Value + 60 Case Target(1).Address = Range("Trigger")(1).Address If Target(1).Value = "AAAA" Then '(1)は結合セルクリア対策 MsgBox "BBBBを入力してください。" Range("BBBB").Select Else Range("BBBB").MergeArea.ClearContents End If Case Target(1).Address = Range("BBBB")(1).Address If Target(1).Value = "日付入力" Then Range("BBBB").Value = InputBox("日付を入力してください。") End If End Select End Sub
- ベストアンサー
- その他MS Office製品
- ドラッグした際のエラー回避
以下のようなVBAを組んだのですが、オートフィルタでV列をリストのいずれかを選択中にドラッグすると「型が一致しません」というエラーを起こします。 最悪、オートフィルタ中はドラッグ不可でもかまいません。 ご教授ください。 （WiｎXp/Access2003) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) '列の色変更 Dim myColor As Variant Dim myFontColor As Variant If Target.Column = 1 Then GoTo S If Target.Column = 9 Then GoTo K If Target.Column = 25 Then GoTo Y If Target.Column = 22 Then GoTo A If Selection.Cells.Count > 1 Then Exit Sub Exit Sub S: 'A列入力時 If Not Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub Application.EnableEvents = False If Target.Value <> "" And Target.Offset(0, 4) = "" And Target.Offset(0, 2) = "" Then Target.Offset(0, 2) = "TypeA" Target.Offset(0, 5) = "未" Target.Offset(0, 6) = Date Target.Offset(0, 1).Select End If Application.EnableEvents = True Exit Sub K: '故障入力時 If Not Intersect(Target, Range("K1:K10")) Is Nothing Then Exit Sub Application.EnableEvents = False If Target.Value = "Y" Then Target.Offset(0, 13) = "故障" Cells(Target.Row, 1).Resize(1, 28).Interior.ColorIndex = 7 Target.Offset(0, 1).Select Else End If Application.EnableEvents = True Exit Sub Y: 'Y列入力時 If Not Intersect(Target, Range("Y1:Y10")) Is Nothing Then Exit Sub Application.EnableEvents = False If Target.Value <> "" And Target.Offset(0, 1) = "" And Target.Offset(0, 2) = "" Then Target.Offset(0, -3) = "売却済" Target.Offset(0, 1) = Date Target.Offset(0, 2) = "未" Cells(Target.Row, 1).Resize(1, 28).Interior.ColorIndex = 16 Else End If Application.EnableEvents = True Exit Sub A: If Not Intersect(Target, Range("A1:AB10")) Is Nothing Then Exit Sub Application.EnableEvents = False Select Case Target.Value Case "故障" myColor = 7 'ピンク myFontColor = 1 Case "修理中" myColor = 37 '薄い水色 myFontColor = 1 Case "担当出(1)" myColor = 3 '赤 myFontColor = 1 Case "担当出(2)" myColor = 8 '水色 myFontColor = 1 Case "担当出(3)" myColor = 4 '蛍光緑 myFontColor = 1 Case "担当出(4)" myColor = 6 '黄色 myFontColor = 1 Case "担当出(5)" myColor = 5 '青 myFontColor = 1 Case "担当出(6)" myColor = 10 '深緑色 myFontColor = 1 Case "売却済" myColor = 16 '濃灰色 myFontColor = 1 Case "廃棄", "修理不可能" myColor = 47 '群青 myFontColor = 2 '白 Case "保守用" myColor = 49 '群青 myFontColor = 2 '白 Case Else myColor = xlNone End Select Cells(Target.Row, 1).Resize(1, 28).Interior.ColorIndex = myColor Cells(Target.Row, 1).Resize(1, 28).Font.ColorIndex = myFontColor Application.EnableEvents = True End Sub Private Sub AFall() If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData End If End Sub
- 締切済み
- Visual Basic
- マクロが動きません
以下のようなプログラムでC3の値が変わるたびにA10の値に1を加えていきG3,H3が両方0になったらA10の値も0にする。C5の値が変わるたびにA15の値に1を加えJ3,K3が共に0になったらC5も0にするようにしました。 しかし、動作しません。 このシートの3行目は＝シート名！セル番号 という形でほかのシートのセルの値が表示されるようになっています。G3、H3、J3、K3に手動で数値を入力した場合 は動作します。 ほかのシートのセルの値を表示させたセルの値が変化しても動作させる方法はないでしょうか＞ Private Sub worksheet_change(ByVal target As Range) With target If .Count > 1 Then Exit Sub If IsNumeric(.Value) = False Then Exit Sub If IsEmpty(.Value) = True Then Exit Sub If Not .Row = 3 Then Exit Sub Select Case .Column Case 3 Range("A10").Value = Range("A10").Value + 1 Case 5 Range("A15").Value = Range("A15").Value + 1 End Select End With If Range("g3").Value = 0 And Rang("h3").Value = 0 Then Range("A10").Value = 0 If Range("j3").Value = 0 And Rang("k3").Value = 0 Then Range("A15").Value = 0 End Sub
- ベストアンサー
- オフィス系ソフト
- EXCEL 異なるVBA
教えて下さい、EXECL以下の異なるVBA (A>,B>)が２つあります、同じシートでそれぞれ動くようにさせたいです1つに合わせる事は出来ないでしょうか? 当方初心者の為わかりません教えて下さい。 A> Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address(0, 0, xlA1, 0) <> "A1" Then Exit Sub With Range("F9:I9,K17:K36").Borders(xlDiagonalUp) If Left$(Target.Value, 1) = "S" Then .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic Else .LineStyle = xlNone End If End With End Sub B> Private Sub Worksheet_Change(ByVal Target As Range) With Sheet2 Select Case Target.Address Case Is = "$D$1" .Range("A1").Insert Shift:=xlDown .Range("A1").Value = Target.Value Case Is = "$D$2" .Range("B1").Insert Shift:=xlDown .Range("B1").Value = Target.Value End Select End With End Sub
- 締切済み
- その他([技術者向] コンピューター)
- エクセルVBAでTargetのセルに設定された「名前の定義」の取得方法は？
例えば、A1、B2、C3セルに「名前の定義」で、それぞれ入力A、入力B、入力C という名前がつけてあります。 それらのセルに入力があった場合、Select Caseで分岐させ作動するマクロをつくりました。 簡略化すると以下のようなもので、一応正しく作動します。 Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("入力A,入力B,入力C")) Is Nothing Then Exit Sub Select Case Target.Address(0, 0) Case "A1" MsgBox "A処理します。" Case "B2" MsgBox "B処理します。" Case "C3" MsgBox "C処理します。" End Select End Sub ただ、せっかくセルに名前を定義してあるのに、個々の入力セルの判定をTarget.Addressでしているのが不満です。 (￣～￣;) 定義された名前を使えないかと以下のようにやってみましたが実行時エラーで「サポートしてません」となってしまいます。 (T.T) Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("入力A,入力B,入力C")) Is Nothing Then Exit Sub Select Case Target.Names.Name 'ここでエラー Case "入力A" MsgBox "A処理します。" Case "入力B" MsgBox "B処理します。" Case "入力C" MsgBox "C処理します。" End Select End Sub どうやったら、Targetに設定されている名前を取得できるのでしょうか？ (^∇^`)？ 実際の例はもっと対象が多いので、Select Caseを使わない以下の方法は避けたいのです。 If文の羅列（これでも正しく作動はします。） Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("入力A,入力B,入力C")) Is Nothing Then Exit Sub If Not Intersect(Target, Range("入力A")) Is Nothing Then MsgBox "A処理します。" ElseIf Not Intersect(Target, Range("入力B")) Is Nothing Then MsgBox "B処理します。" Else MsgBox "C処理します。" End If End Sub なにとぞよろしくお願いします。 (o。_。)oペコッ
- ベストアンサー
- オフィス系ソフト
お礼
早速ご指導いただき、ありがとうございます。 コピーペーストできました！ 本当にありがとうございました。