[[20170316115240]] 『オートシェイプの色を条件によって変えたい。』(キタ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『オートシェイプの色を条件によって変えたい。』(キタ)

はじめまして、Excel初心者です。

いま、バレーボール大会のトーナメント表を作っており、
試合結果を入力し、トーナメントの上りチームを自動で表示させています。

チーム名等はExcel関数で処理できたのですが、
トーナメント表の線(オートシェイプで書いたL字の線)の、上がったチームの方を赤く表示したいです。※可能ならば表示順序も最前面にしたいです。
もちろん勝ちチームのフラグ(1:勝、2:負)は拾うことが可能です。

色々と試してみたのですが、うまくいきませんでした。
どなたか親切な方、ご教示頂けると嬉しいです。

よろしくお願いします。

< 使用 Excel:Excel2016、使用 OS:Windows10 >


 入力規則と名前の定義で出来るようです。
 事前準備が必要ですが。

 下記を参照してみてください。
 これが難しければマクロ対応になるかと思います。

 http://yasu-excel.blogspot.jp/2014/07/blog-post_18.html
(2Win) 2017/03/16(木) 13:29

ありがとうございます。

この方法だと線以外もはりついてしまうので、トーナメント表には厳しそうです。
もしよければ、マクロでのアドバイスをお願いします。
(キタ) 2017/03/16(木) 14:33


 では簡単なマクロですが、ボタンで色を変える方法を。
 マクロは触ったことはありますか?

 開発タブからVisual Basicを起動して、挿入→標準モジュールを挿入してください。
 右に標準モジュールが追加されますので、下記のコードを貼り付けてください。

 Sub 線を赤にする()
    Dim 線 As ShapeRange
        On Error Resume Next
        Set 線 = Selection.ShapeRange
        On Error GoTo 0
            If 線 Is Nothing Then
                MsgBox "図形が選択されていません。"
                Exit Sub
            End If
            線.Line.ForeColor.RGB = RGB(255, 0, 0)
 End Sub

 Sub 線を黒にする()
    Dim 線 As ShapeRange
        On Error Resume Next
        Set 線 = Selection.ShapeRange
        On Error GoTo 0
            If 線 Is Nothing Then
                MsgBox "図形が選択されていません。"
                Exit Sub
            End If
            線.Line.ForeColor.RGB = RGB(0, 0, 0)
 End Sub

 貼り付けたらExcelに戻って、「開発」タブの「挿入」→フォームコントロール「ボタン」
 好きな場所へボタンを挿入してください。
 マクロの登録画面が出ると思いますので、「線を赤にする」を選択してOKをクリック。
 同じようにボタンを挿入して、「線を黒にする」を選択してOKをクリック。

 これで線を赤にするボタンと線を黒にするの2つのボタンができました。
 色を変えたいシェイプを選択してボタンを押せば色が変わります。
 シェイプを選択しないでボタンを押すと警告文が出ます。

 というか、線で良かったんですかね?線ではなく中身の塗りつぶしの場合は
 線.Line.ForeColor.RGB を線.Fill.ForeColor.RGBに変えてみてください。
(2Win) 2017/03/16(木) 15:22

2Winさん、ご親切にありがとうございます!
困っているので本当に助かります。
マクロは、サンプルを見つけてそれを加工して使ったことがある程度です。

関数で出力されたふたつの数値(セル)を比較して、大きい方の線を赤にしたいのです。
非入力および数値が小さい場合は、黒のままです。

要するにこんな感じです↓
https://www.dropbox.com/s/ml79x2ouu0al6y5/Question01.xlsx?dl=0
https://www.dropbox.com/s/mn9nwjhe9x90dpp/Question01.png?dl=0

すっかり甘えてしまってすみません。
ご教授頂けると幸いです。
(キタ) 2017/03/16(木) 16:29


 あまりキレイなコードではないんですが、例を参考に書いてみました。
 値を変更したら色が変わるようになっています。
 対象のシート名のシートモジュールに貼り付けてください。
 値を増やしてますので、実際のレイアウトに合わせて変更してください。

 Option Explicit
 Private Sub worksheet_change(ByVal target As Range)
    Dim 線1 As Shape, 線2 As Shape, 線3 As Shape, 線4 As Shape
        Set 線1 = Sheets("sheet1").Shapes("カギ線コネクタ 1")
        Set 線2 = Sheets("sheet1").Shapes("カギ線コネクタ 2")
        Set 線3 = Sheets("sheet1").Shapes("カギ線コネクタ 3")
        Set 線4 = Sheets("sheet1").Shapes("カギ線コネクタ 4")
        '図形の名前はシートの「書式」→「オブジェクトの選択と表示」から確認

            If Intersect(target, Range("C14,G14,C25,G25")) Is Nothing Then    'Rangeの後に値を変更するセル番号を適宜追加してください。
                Exit Sub
            Else

                If Range("C14") > Range("G14") Then         '★1
                    線1.Line.ForeColor.RGB = RGB(255, 0, 0) '★1
                    線2.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                ElseIf Range("C14") < Range("G14") Then     '★1
                    線1.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線2.Line.ForeColor.RGB = RGB(255, 0, 0) '★1
                End If                                      '★1

                If Range("C25") > Range("G25") Then         '★2
                    線3.Line.ForeColor.RGB = RGB(255, 0, 0) '★2
                    線4.Line.ForeColor.RGB = RGB(0, 0, 0)   '★2
                ElseIf Range("C25") < Range("G25") Then     '★2
                    線3.Line.ForeColor.RGB = RGB(0, 0, 0)   '★2
                    線4.Line.ForeColor.RGB = RGB(255, 0, 0) '★2
                End If                                      '★2

            End If

 End Sub

 注釈に書いてある通り、変数の線1〜4に書いてあるShape名を確認して変更してください。
 ★1が後ろに書いてあるのが例に挙がっていた値のIfの固まりです。
 ★2は勝手に追加した値の固まりですので、変更して試してみてください。
 追加があれば★の固まりをコピーして最後のEnd Ifの前に貼り付けて追加してください。
 追加する場合はセル番号の追加、変数の宣言、Shape名とSetを忘れないようにお気をつけください。

 分からない箇所があれば質問していただければ分かる範囲でお答えします。
 ※ちなみに、同点の場合を考えておりませんのであしからず。

 ●追記
 シート名が「sheet1」になっていますので、実際のシート名に変えてくださいね。

 ●更に追記(すみません
 数式で値を出しているのであれば、数式が入っているセルではなく実際に数字を入力するセルを指定してください。
 うまくいかない場合は数式が入っているセルをF2選択してEnterでも可です。

(2Win) 2017/03/17(金) 09:50


2Winさん、ありがとうございます!
10チームのトーナメント戦なので、補足説明がとてもありがたいです!
※同点は無いので大丈夫です^^;

とにかくチャレンジしてみます。
また報告しますね!
(キタ) 2017/03/17(金) 10:41


ありがとうございます!
成功しました!本当にありがとうございます。

ひとまず1試合分だけですが、こんな感じのコードでうまく動いています。
ついでに線の太さもコントロールできました^^

全25試合あるので、これを全てに組んでやっていきます。
ちなみに、線の優先順位(最前面へ移動)は指定できないでしょうか?
自分で調べてはみたのですが、太さ指定しかたどり着きませんでした。

 Private Sub worksheet_change(ByVal target As Range)
    Dim 線1 As Shape, 線2 As Shape
        Set 線1 = Sheets("対戦表&進行表").Shapes("TeamAwin")
        Set 線2 = Sheets("対戦表&進行表").Shapes("TeamBwin")
            If Intersect(target, Range("N5:O7")) Is Nothing Then    
                Exit Sub
            Else
                If Range("X4") > Range("X6") Then         '★1
                    線1.Line.ForeColor.RGB = RGB(255, 0, 0) '★1
                    線2.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線1.Line.Weight = 5                     '★1
                    線2.Line.Weight = 2                     '★1
                ElseIf Range("X4") < Range("X6") Then     '★1
                    線1.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線2.Line.ForeColor.RGB = RGB(255, 0, 0) '★1
                    線1.Line.Weight = 2                     '★1
                    線2.Line.Weight = 5                     '★1
                ElseIf Range("X4") = Range("X6") Then     '★1
                    線1.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線2.Line.ForeColor.RGB = RGB(0, 0, 0) '★1
                    線1.Line.Weight = 2                     '★1
                    線2.Line.Weight = 2                     '★1
                End If                                      '★1
            End If
 End Sub
(キタ) 2017/03/17(金) 13:16

 シェイプの位置を前面に持って行きたい場合はShapeではなくShapeRangeで指定しないといけません。

 例えば線1の場合は(宣言する名前は何でもいいのですが)、Dim 線1R As ShapeRange と宣言します。
 新しい変数に Set 線1R = Sheets("対戦表&進行表").Shapes.Range("TeamAwin") とします。

 Ifの線の色を赤に変える箇所の下あたりで 線1R.ZOrder msoBringToFront と入れてみてください。
 赤に変わった後、最前面に移動すると思います。

 後は他のシェイプも同じようにコードを追加してあげればいけると思います。

 掲示されたコードで追加してみますと

 Private Sub worksheet_change(ByVal target As Range)
    Dim 線1 As Shape, 線2 As Shape
    Dim 線1R As ShapeRange, 線2R As ShapeRange     '新しい宣言

        Set 線1 = Sheets("対戦表&進行表").Shapes("TeamAwin")
        Set 線2 = Sheets("対戦表&進行表").Shapes("TeamBwin")
        Set 線1R = Sheets("対戦表&進行表").Shapes.Range("TeamAwin")  '新しいSet
        Set 線2R = Sheets("対戦表&進行表").Shapes.Range("TeamBwin")  '新しいSet
            If Intersect(target, Range("N5:O7")) Is Nothing Then    
                Exit Sub
            Else
                If Range("X4") > Range("X6") Then         '★1
                    線1.Line.ForeColor.RGB = RGB(255, 0, 0) '★1
                    線2.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線1.Line.Weight = 5                     '★1
                    線2.Line.Weight = 2                     '★1
                    線1R.ZOrder msoBringToFront             '☆ここが新規
                ElseIf Range("X4") < Range("X6") Then     '★1
                    線1.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線2.Line.ForeColor.RGB = RGB(255, 0, 0) '★1
                    線1.Line.Weight = 2                     '★1
                    線2.Line.Weight = 5                     '★1
                    線2R.ZOrder msoBringToFront             '☆ここが新規
                ElseIf Range("X4") = Range("X6") Then     '★1
                    線1.Line.ForeColor.RGB = RGB(0, 0, 0)   '★1
                    線2.Line.ForeColor.RGB = RGB(0, 0, 0) '★1
                    線1.Line.Weight = 2                     '★1
                    線2.Line.Weight = 2                     '★1
                End If                                      '★1
            End If
 End Sub

 これで実行してみてください。
(2Win) 2017/03/17(金) 15:26

2winさん、何度もありがとうございます!

まだ4試合分ですが、このコードでうまく行きました!
なぜかShapeのままで、最前面に表示されてくれました^^

このまま、あと21試合分を重ねていきます^^;
Dim(宣言)は、25試合分だと長くなるので、複数行で定義してもいいんですね?

 Private Sub worksheet_change(ByVal target As Range)

    Dim 線11Awin As Shape, 線11Bwin As Shape, 線12Awin As Shape, 線12Bwin As Shape, 線22Awin As Shape, 線22Bwin As Shape, 線23Awin As Shape, 線23Bwin As Shape

        Set 線11Awin = Sheets("対戦表&進行表").Shapes("1-1Awin")
        Set 線11Bwin = Sheets("対戦表&進行表").Shapes("1-1Bwin")
        Set 線12Awin = Sheets("対戦表&進行表").Shapes("1-2Awin")
        Set 線12Bwin = Sheets("対戦表&進行表").Shapes("1-2Bwin")
        Set 線22Awin = Sheets("対戦表&進行表").Shapes("2-2Awin")
        Set 線22Bwin = Sheets("対戦表&進行表").Shapes("2-2Bwin")
        Set 線23Awin = Sheets("対戦表&進行表").Shapes("2-3Awin")
        Set 線23Bwin = Sheets("対戦表&進行表").Shapes("2-3Bwin")

            If Intersect(target, Range("N5:U43")) Is Nothing Then
                Exit Sub
            Else

                If Range("N8") > Range("O8") Then
                    線11Awin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線11Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線11Awin.Line.Weight = 5
                    線11Bwin.Line.Weight = 2
                    線11Awin.ZOrder msoSendToFront
                ElseIf Range("N8") < Range("O8") Then
                    線11Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線11Bwin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線11Awin.Line.Weight = 2
                    線11Bwin.Line.Weight = 5
                    線11Bwin.ZOrder msoSendToFront
                ElseIf Range("N8") = Range("O8") Then
                    線11Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線11Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線11Awin.Line.Weight = 2
                    線11Bwin.Line.Weight = 2
                End If

                If Range("N14") > Range("O14") Then
                    線12Awin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線12Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線12Awin.Line.Weight = 5
                    線12Bwin.Line.Weight = 2
                    線12Awin.ZOrder msoSendToFront
                ElseIf Range("N14") < Range("O14") Then
                    線12Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線12Bwin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線12Awin.Line.Weight = 2
                    線12Bwin.Line.Weight = 5
                    線12Bwin.ZOrder msoSendToFront
                ElseIf Range("N14") = Range("O14") Then
                    線12Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線12Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線12Awin.Line.Weight = 2
                    線12Bwin.Line.Weight = 2
                End If

                If Range("P14") > Range("Q14") Then
                    線22Awin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線22Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線22Awin.Line.Weight = 5
                    線22Bwin.Line.Weight = 2
                    線22Awin.ZOrder msoSendToFront
                ElseIf Range("P14") < Range("Q14") Then
                    線22Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線22Bwin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線22Awin.Line.Weight = 2
                    線22Bwin.Line.Weight = 5
                    線22Bwin.ZOrder msoSendToFront
                ElseIf Range("P14") = Range("Q14") Then
                    線22Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線22Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線22Awin.Line.Weight = 2
                    線22Bwin.Line.Weight = 2
                End If

                If Range("P20") > Range("Q20") Then
                    線23Awin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線23Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線23Awin.Line.Weight = 5
                    線23Bwin.Line.Weight = 2
                    線23Awin.ZOrder msoSendToFront
                ElseIf Range("P20") < Range("Q20") Then
                    線23Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線23Bwin.Line.ForeColor.RGB = RGB(255, 0, 0)
                    線23Awin.Line.Weight = 2
                    線23Bwin.Line.Weight = 5
                    線23Bwin.ZOrder msoSendToFront
                ElseIf Range("P20") = Range("Q20") Then
                    線23Awin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線23Bwin.Line.ForeColor.RGB = RGB(0, 0, 0)
                    線23Awin.Line.Weight = 2
                    線23Bwin.Line.Weight = 2
                End If

            End If
 End Sub
(キタ) 2017/03/17(金) 16:31

 Shapeでいけましたか。あれ?(笑)
 勉強不足で申し訳ないです。

 宣言はもちろん複数行で構いません。
 むしろ1行ずつ書いたほうがいいです。本当は。

 コードも、Do〜LoopやFor〜Next等の繰り返し文を使えばもっとスマートに書けると思います。

 がんばってみてください。

(2Win) 2017/03/17(金) 16:50


いえいえ、2Winさん。
本当にありがとうございます!
半ば諦めていたので、本当に感謝しています。

実は、四半世紀以上前にエンジニアをやっていたことはあったのですが、
遠い昔のことで、すっかり勘が鈍くなってしまっていました^^;

これを機に、少し色々とチャレンジしてみようと思います。
Excel自体は、仕事でも使っているので。

今回は、本当にありがとうございました!
完成したら、また報告しますね^^
(キタ) 2017/03/17(金) 17:19


2winさん。

あらためて、この度はありがとうございました!
無事に全てのトーナメント表が完成し、大会をスムーズに運営する事が出来ました。

実際のExcelはこんな感じです^^
http://bit.ly/2nKPq4f

2winさん、本当にありがとうございました。
これをきっかけに、他の大会でも色々とチャレンジしてみようと思っています。
(キタ) 2017/03/23(木) 11:20


 すごくカッコいいトーナメント表ですね!
 チームがたくさんあるみたいなので大変だったと思います。お疲れ様でした。

 私もShapeはあまりマクロで触ることが無いので勉強になりました。
 ありがとうございました。
(2Win) 2017/03/23(木) 11:54

結局どちらで解決したんだろうね。

http://www.moug.net/faq/viewtopic.php?t=75408
(通りすがり) 2017/03/23(木) 12:32


 マルチポストだったんですね。気づかなかったです。
 まぁ、解決したならどちらでもいいと思います(笑
(2Win) 2017/03/23(木) 12:37

 どちらも、ちゃんと、それぞれの回答に対してレスしていて、
 近頃には珍しい、ちゃんとした(?)マルチポスターさんだと思いました。

(β) 2017/03/23(木) 16:11


2Winさん、通りすがりさん、βさん。

複数の掲示板に質問を投げるのはルール違反だったんですね。
なんとかあの表を完成させたく、親切な方が居ないかと頼ってしまいました。
大変失礼いたしました。勉強になりました。

解決したのは、2Winさんの的確なアドバイスです。
私が求めているものを、先回りしてアドバイス頂いたので、
素人の私でもなんとかなりました^^

おかげでExcelの可能性や楽しさをあらためて教えて頂きました。
本当にありがとうございました!
(キタ) 2017/03/24(金) 10:38


 キタさん
 こちらの掲示板ではマルチポストはルール違反ではありません。
 詳しくは画面上の方の「初めての方へ」に記載されておりますのでご一読ください。
 今回別途質問されていたモーグの方の掲示板も禁止ではないようですし、ご安心ください。
 ただ、他の掲示板で同じ質問をされている場合はその旨と、他の掲示板の方で解決した場合はその旨を書いていただければ大丈夫だと思います。

 別の掲示板ではマルチポストは禁止事項になっている場合がありますので、そこは気をつけていただければと思います。
 ここでは問題なくても他方の掲示板では禁止だった!という場合がありますので。

 βさんがおっしゃってます通り、キタさんはこちらの掲示板でも違う掲示板でも丁寧にレスをされていらっしゃったので個人的には全然問題ないと思います。

(2Win) 2017/03/24(金) 11:35


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.