[[20131224093607]]　『オートシェイプ数値で塗りつぶし』（チーター）　ページの最後に飛ぶ

『オートシェイプ数値で塗りつぶし』（チーター）

オートシェイプで作った図形の色を、あるセルに入った数値を見て変化させたいのですが出来ますか?? 例えば・・・図形1はA1の数値をみる。図形2はA2の数値をみる。それぞれの図形を数値1なら赤、2なら青と塗りつぶしたいです。また色の番号の指定（例：赤の場合8など・・）は何処でわかるのでしょうか。宜しくご教授下さい。

＜使用 Excel：Excel2007、使用 OS：Windows7 ＞

 マクロになるとおもいます。

 色と番号の対比表は↓で取得できます。

 Sub test()
  Dim i As Integer
   For i = 1 To 56
    ActiveSheet.Cells(i, 1).Interior.ColorIndex = i
    ActiveSheet.Cells(i, 2).Value = i
   Next i
 End Sub

 選択(１つのみの場合)しているシェイプの背景色をアクティブセルの値
 で設定するサンプルです。

 Sub testB()
  Dim sp As Object
  Dim iro As Integer
   iro = ActiveCell.Value
   Set sp = Selection.ShapeRange
   sp.Fill.ForeColor.RGB = ThisWorkbook.Colors(iro)
   Set sp = Nothing
 End Sub

 シェイプの指定はシェイプを選択しない方法もあります。
（カリーニン） 2013/12/24(火) 10:00

早速お答えありがとうございます。TEST　をVBAに貼り付け保存、図形１を作成⇒A１に数値入力しましたが変化ありませんでした。同様にtestBを貼り付けましたが同じ結果です。何処か数値など変更するところがあるのでしょうか？引き続きご教授いただけるとありがたいです。
（チーター） 2013/12/24(火) 11:02

 >それぞれ の図形を数値1なら赤、2なら青と塗りつぶしたいです

 数値1なら赤、2なら青ではありませんが、
 1～56番号に割り振られた色が返ります。

 シートモジュールに貼り付けて下さい。

 図形の名前を登録してから実行してください。
 1.オートシェイプを選択します。
 2.画面左上の▼の左横「名前ボックス」にそれぞれ図形1・図形2の名前を入力します。
   入力後Enter押下で確定して下さい。
　A1・A2に　1～56までの数字を入力、試してみて下さい。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x As Long
    For x = 1 To 56
    Set myr1 = Range("A1")
    Set myr2 = Range("A2")
      Select Case myr1
         Case x
              With ActiveSheet.Shapes("図形1").Fill
                 .Visible = msoTrue
                 .Solid
                 .ForeColor.SchemeColor = myr1
              End With
               With ActiveSheet.Shapes("図形2").Fill
                 .Visible = msoTrue
                 .Solid
                 .ForeColor.SchemeColor = myr2
              End With
          Case Is <> x
         End Select
      Next x
 End Sub

（塩こんぶ） 2013/12/24(火) 12:29

 図形1.2でした、訂正しました。
（塩こんぶ） 2013/12/24(火) 13:00

塩こんぶさん　凄いです！ありがとうございます。本当に助かりました。
（チーター） 2013/12/24(火) 14:08

 少し前に、似たような質問があって
 　　投稿する前に削除されてしまったのですが
 その時に作ってたコードを載せてみます。

 A列に1～3の数値を入れると
 そのセルと、 同じ行にある図形（厳密には図形の左上がある図形）とに
 色を付けるマクロです。

 色数を増やしたい場合は、
                Case ○
                    MyCol = ●
 部分を増やして下さい。

 色番号と色の対応は
[[20091207105045]]?　『色の番号』（ｌｌ）
 こちらのスレで、ｍｏｍｏさんが最初に投稿されているコードを実行して
 確認してみて下さい。

 '------
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyCol As Long
    Dim MySp As Shape

    With Target
        If .Column = 1 Then
            Select Case .Value
                Case 1
                    MyCol = 38  '赤
                Case 2
                    MyCol = 37  '黄
                Case 3
                    MyCol = 36  '青
                Case Else
                    MyCol = 2   '白
            End Select
        End If
            .Interior.ColorIndex = MyCol
            For Each MySp In ActiveSheet.Shapes
                If MySp.TopLeftCell.Row = .Row Then
                    MySp.Fill.Visible = msoTrue
                    MySp.Fill.ForeColor.SchemeColor = MyCol + 7
                End If
            Next
    End With
End Sub
 '------
 　
（HANA） 2013/12/24(火) 14:38

いろいろとありがとうございます。少々私には（HANAさんが教えてくれたこと）難しいレベルです。（なにをどうやっていのか・・）
（チーター） 2013/12/24(火) 15:17

 とりあえず、新しいブックの新しいシートで
 行幅を広くして　1行目と2行目に収まるように
 オートシェイプを配置して下さい。

 シートモジュールに、私が載せたコードを書いて
 A1セルに「1」を入力してみて下さい。

 A1セルの色と、1行目に配置したオートシェイプがピンク色に変わると思います。

 今の所、1～3迄設定してあります。
 それ以外が入力されると　白　になります。

 上手くいかない場合は、どの様になったか、教えて下さい。
 　エラーが出てとまる。何も起きない。。。。等
 　
（HANA） 2013/12/24(火) 17:20

 (チーター）さん　すみませんが

 再度の訂正です、下記コードと差し替えて下さい。
 先のコードだとA1とA2に同じ数字を入力しても違う色を表示します。

 （HANA）さんの書かれたコードが(チーター）さんのご希望により近いですね。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x As Long
    For x = 1 To 56
    Set myr1 = Range("A1")
    Set myr2 = Range("A2")
      Select Case myr1
         Case x
              With ActiveSheet.Shapes("図形1").Fill
                 .Visible = msoTrue
                 .Solid
                 .ForeColor.SchemeColor = myr1+7
              End With
              End Select
      Select Case myr2
          Case x
               With ActiveSheet.Shapes("図形2").Fill
                 .Visible = msoTrue
                 .Solid
                 .ForeColor.SchemeColor = myr2+7
              End With
          Case Is <> x
         End Select
      Next x
 End Sub
（塩こんぶ） 2013/12/25(水) 01:04

 ばたばたしてたので回答が遅くなりました。といっても今更ですが・・・。

 私の 2013/12/24(火) 10:00 のレスは単なるたたき台のつもりでした。
 ですので、そのまま実行しても何の役にも立ちません。

 >test
 これは、色と番号の対比を取得する物です。
 しかも、↓のコードの方がより適切でした。

 Sub testC()
  Dim rect As Object
  Dim wd As Single
  Dim ht As Single
  Dim lt As Single
  Dim tp As Single
  Dim i As Integer
   'ActiveSheet.DrawingObjects.Delete
   For i = 1 To 56
    lt = ActiveSheet.Cells(i, 1).Left
    tp = ActiveSheet.Cells(i, 1).Top
    wd = ActiveSheet.Cells(i, 2).Left - ActiveSheet.Cells(i, 1).Left
    ht = ActiveSheet.Cells(i + 1, 1).Top - ActiveSheet.Cells(i, 1).Top
    Set rect = ActiveSheet.Shapes.AddShape(msoShapeRectangle, lt, tp, wd, ht)
    With rect
    .Fill.ForeColor.RGB = ThisWorkbook.Colors(i)
    .Line.Visible = msoFalse
    End With
    ActiveSheet.Cells(i, 2).Value = i
    ActiveSheet.Cells(i, 3).Interior.Color = rect.Fill.ForeColor
    ActiveSheet.Cells(i, 4).Value = ActiveSheet.Cells(i, 3).Interior.ColorIndex
    Set rect = Nothing
   Next i
 End Sub

 >testB
 これは
 >選択(１つのみの場合)しているシェイプの背景色をアクティブセルの値
 >で設定するサンプルです。
 のとおりです。

 このコードをたたき台にしてお望みの形へ修正してもらうつもりでした。
 余談ですが、testCを実行したらわかるように、パソコンの設定によっては
 色番号をデフォルトから変えている場合があるので注意が必要です。
 RGB指定なら問題ないと思いますが。

 シェイプの色やコントロール類の色をセルの色から指定するときは近い色を
 判断して着色しているようです。

 また、56色の中には同じ色や近い色があるので、
 セルの数値でシェイプの色を設定
 ↓
 シェイプの色から色番号を取得

 とすると、違う番号が帰ってくる可能性があります。
 まあ、今回の質問には関係ない話ですが・・・。
（カリーニン） 2013/12/27(金) 10:10

コメント返信：

[ 一覧(最新更新順) ]

[[20131224093607]] 『オートシェイプ数値で塗りつぶし』（チーター） ページの最後に飛ぶ

[[20131224093607]]　『オートシェイプ数値で塗りつぶし』（チーター）　ページの最後に飛ぶ