[[20130519185406]]　『エクセル２０１０　セルの値で、フリーフォームに』（いがです。）　ページの最後に飛ぶ

『エクセル２０１０　セルの値で、フリーフォームに色を付けたい。』（いがです。）

エクセルのVBAで困っております。
ご教授をお願い致します。

Sheet1にフリーフォームで書いた図形が、数十個あります。（最終的には３００個程度）
この図形の塗りつぶしの色を、Sheet2の「E」列のセルの値により変えたいと思っております。（E1～E300）
E列の入力値は、１～５までです。
１：赤、２：黄、３：緑、４：ピンク、５：水色とし塗りつぶしたいと思っております。
Sheet１のフリーフォームとSheet2のセルの関係は固定です。
E1=フリーフォーム１、E2=フリーフォーム２・・・（途中で変わる事はありません）

こんな事を書いて起きながら申し訳ないのですが、当方素人ですので、丁寧に説明していただけると幸いです。

お手数をお掛けいたしますが、よろしくお願い致します。

 丁寧に説明・・・・う～ん・・・・

 まず、コードを試してみて、あとは、調べてコードを読解して、わからないところを質問してくれる？

 あと、素人でというのは、最初は誰でもそうなんだけど、フリーフォームで作った図形の背景色を、たとえば水色にする。
 それをマクロ記録して、どんなコードで背景色が図にセットされるのか確認する。
 それは当然、もうやっているんだよね？

 Sub Sample()
    Dim ff As Shape
    Dim n As Long
    Dim x As Long

    For Each ff In Sheets("Sheet1").Shapes
        If ff.Type = msoFreeform Then
            n = Val(Split(ff.Name)(1))
            If n > 0 Then
                x = Val(Sheets("Sheet2").Range("E1").Offset(n - 1).Value)
                Select Case x
                    Case 1 To 5
                       ff.Fill.ForeColor.RGB = VBA.Array(vbRed, vbYellow, vbGreen, vbMagenta, vbCyan)(x - 1)
                End Select
            End If
        End If
    Next

 End Sub

 (ぶらっと)

 ↑ アップしたコードはフリーフォームの名前が　フリーフォーム 1 といったように、文字と数字の間に半角スペースがあるということを前提。
 （文字は　フリーフォーム　でなくてもいいけど）
 そうでないならエラーになる。

 (ぶらっと)

ぶらっと様

ご回答ありがとうございます。
ご指導いただき少しづつ勉強してまいります。
sampleで問題なく反映出来る事は確認出来ました。
もう少し追加で質問ですが、sampleは、E1=フリーフォーム 1,E2=フリーフォーム 2・・・
となってるかと思いますが、参照するセルとフリーフォームの関係を個別に指定する事は可能でしょうか？
フリーフォームの名前を任意に変更し、それとリンクしたE列のセルを指定する。
例：フリーフォーム 10-1=E3、フリーフォーム 2-3=E1、フリーフォーム 1-3=E1・・・とランダムな関係になります。
よろしくお願い致します。

（いがです。）

 D列に 10-1 とか、 E列に色番号。

 Sub Sample2()
    Dim ff As Shape
    Dim x As Long
    Dim c As Range
    Dim sh2 As Worksheet

    Set sh2 = Sheets("Sheet2")
    For Each c In sh2.Range("D1", sh2.Range("D" & sh2.Rows.Count).End(xlUp))
        Set ff = Nothing
        On Error Resume Next
        Set ff = Sheets("Sheet1").Shapes("フリーフォーム " & c.Value)
        On Error GoTo 0
        If Not ff Is Nothing Then
            x = Val(c.Offset(, 1).Value)
            Select Case x
                Case 1 To 5
                   ff.Fill.ForeColor.RGB = VBA.Array(vbRed, vbYellow, vbGreen, vbMagenta, vbCyan)(x - 1)
            End Select
        End If
    Next

 End Sub

 (ぶらっと)

ぶらっと様
ご回答ありがとうございます。

Sample2も問題なく反映出来る事は確認出来ました。
すみません、もう一点お願いがございます。（どんどん欲が出てきてしまって。。。）

現状のマクロでは、Sheet2のE列に１～５の値を入力後に、マクロを実行しないと
Sheet1のフリーフォームの色が変化しないと思いますが、Sheet2のE列の値が変われば、
そのままSheet1のフリーフォームの色が変わる様に出来ないでしょうか？

よろしくお願い致します。

（いがです。）

 Sample のこと？　Sample2 のこと？
 いずれにしても、できるけど、Sample2 の場合、ちょっと（操作と実行のタイミングが）ややこしくねるね。

 たとえば、D1 に 1 と記入してあった。
 で、E1 を 1(赤) にした。なので、その瞬間に フリーフォーム 1 の背景色を赤にする。
 これは、どうってことないんだけど、問題は、
 あっ！間違った、赤にするのは　フリーフォーム 2 だった！
 ということで、D1 を 2 にかえた。このときも反映させたいんじゃないかな？
 でも、そうすると、赤にしたフリーフォーム 1 は？　間違いだったので、元に戻す？
 元の色は？

 まぁ、やりかたとしては、D列であれE列であれ、何かしら値の入力があれば、その入力された対象だけではなく
 全フリーフォームの色を洗いがえるというのが操作も考えたときシンプルだと思う。

 標準モジュールに書いたSample2 は、そのままにして、Sheet2のシートタブを右クリック。
 コードの表示を選んで出てくるところ（Sheet2のシートモジュール）に以下を貼り付け、
 右上のＸボタンをおしてエクセルに戻って、D列やE列を適当に変えてみて。

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("D:E")) Is Nothing Then Sample2
 End Sub

 (ぶらっと)

ぶらっと様

今回いろいろと適切にご回答いただきありがとうございました。
Sample2＋最後の回答で問題なく行けそうです。

（いがです。）

先日、上記の件を質問させていただきました。
Sample2＋最後の回答で問題なく対応できておりますが、色を付けるシートを、もう1シート追加し（sheet１をコピーして使用します。）つける色もSample2と違う色のバージョンを作ろうと思っております。（色表示の順番を入れ替えて使用予定）
また、sheet２の入力もE列はそのままに、F列の値を参照する様にします。
（sheet2のE列の数値を変更すると、sheet1の色が変化、sheet2のF列の数値を変更すると、sheet1コピーの色が変化する）
D列と各フリーフォームは、変更ありません。

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("D:E")) Is Nothing Then Sample2
 End Sub

上記のを変更すれば出来そうな気がしましたが、エラーで動いてくれませんでした。

お手数をお掛け致しますが、よろしくお願い致します。

（いがです。）

 >上記のを変更すれば出来そうな気がしましたが、エラーで動いてくれませんでした。

 実際に、変更（追加？）したコードをアップしてくれる？
 それと、エラーというのは、どんなエラーなのか、そのエラーメッセージも教えて。

 (ぶらっと)

 そちらが変更したコードを見てみたい気もするけど、とりあえず。

 コードの前に、前回は最初に標準モジュールのコードを作成して、後で、Sheet2のイベント処理を追加。
 標準モジュールはそのままで使う方法にしたけど、標準モジュールを廃止して、Sheet2のシートモジュール一本で
 処理する構えにしよう。

 Sheet2 の E列が Sheet1 のフリーフォーム用、F列が Sheet3 のフリーフォーム用にしてある。
 シート名は実際のものに変更してね。

 Sheet2 のシートモジュールを以下で置換。

 Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns("D:F")) Is Nothing Then
        Sample3 Sheets("Sheet1"), "E"
        Sample3 Sheets("Sheet3"), "F"
    End If
 End Sub

 Private Sub Sample3(sh As Worksheet, col As String)
    Dim ff As Shape
    Dim x As Long
    Dim c As Range

    For Each c In Range("D1", Range("D" & Rows.Count).End(xlUp))
        Set ff = Nothing
        On Error Resume Next
        Set ff = sh.Shapes("フリーフォーム " & c.Value)
        On Error GoTo 0
        If Not ff Is Nothing Then
            x = Val(c.EntireRow.Range(col & 1).Value)
            Select Case x
                Case 1 To 5
                   ff.Fill.ForeColor.RGB = VBA.Array(vbRed, vbYellow, vbGreen, vbMagenta, vbCyan)(x - 1)
            End Select
        End If
    Next

 End Sub

 (ぶらっと)

ぶらっと様

中途半端で分かりにくい質問にも、適切にご回答いただきましてありがとうございます。
今回も非常に助かりました。

（いがです。）

コメント返信：

[ 一覧(最新更新順) ]

[[20130519185406]] 『エクセル２０１０ セルの値で、フリーフォームに』（いがです。） ページの最後に飛ぶ

[[20130519185406]]　『エクセル２０１０　セルの値で、フリーフォームに』（いがです。）　ページの最後に飛ぶ