[[20160409205512]]　『自動でオートシェイプ内に文字を入れる』（nao）　ページの最後に飛ぶ

『自動でオートシェイプ内に文字を入れる』（nao）

一括してオートシェイプの中に文字を入れる方法を検索していて、見つけたVBAを使用させて頂きたいのですが、かなり改良が必要です。可能か否かわかりませんが、どうかご教授下さい。

やりたい事は
Sheet1に文字入りオートシェイプを表示させたい表があります。
Sheet2に勤務表があります。
勤務表の当日勤務者の名前のみオートシェイプに入れてSheet1に表示させたいのです。
つまり休みの人は表示させない。

Sheet2の勤務表のレイアウトです。

   　 A   B   C   D   E   F   G   H   I   J   K   L・・・・
 1　     1日   2   3   4   5   6   7   8   9   10  11・・・31日
 2  　　　金  土　日　月　火　水  木　金  土  日  月・・・
 3  田中  A   A   A   A   休  A   A   A   A   休  休・・・
 4  佐藤  休  A   A   A   休  A   A   休  A   A   A・・・
 5  石井  A   A   休  A   A   A  休   A   A   A   A・・・

 A1に平成２８年４月が入ります。
 A行が名前で25人入ってます。
 勤務表の「A」表記は勤務コードで数種類あります。
 1日の勤務者をみて、上記表だと田中と石井をSheet1の表にオートシェイプで表示。

Sheet1の表に表示させたい場所はK70セルを先頭に2行で。
オートシェイプの色はオレンジで。

下記が検索で見つけたコードです。

 Sub A列の文字列のシェイプを一括作成()

    Dim shapeType As String
    Dim shapeW As Integer
    Dim shapeH As Integer
    Dim kaigyo As Integer
    Dim i As Integer

     '=== シェイプの形と大きさを決めて下さい ここから ===
    shapeType = msoShapeRectangle    'シェイプの形

    shapeW = 20                'シェイプの大きさ（横幅）
    shapeH = 10             'シェイプの大きさ（高さ）
    kaigyo = 2                     '何個おきに改行させるか
    '=== シェイプの形と大きさを決めて下さい ここまで ===

    Dim maxRow As Integer
    maxRow = Range("A65536").End(xlUp).Row

    Dim myShape As Shape

    Dim rcode() As String 'シェイプ内の文字列その1
    Dim rtitle() As String 'シェイプ内の文字列その2
    ReDim rcode(maxRow)
    ReDim rtitle(maxRow)

    Dim shapeRow As Integer 'シェイプを作る行
    Dim shapeCol As Integer 'シェイプを作る列
    shapeRow = 0

    For i = 1 To maxRow
        'A列とB列の値を取得
        rcode(i) = ActiveSheet.Cells(i, 1).Value
        rtitle(i) = ActiveSheet.Cells(i, 2).Value

        'シェイプを作る位置を決める。
        If i Mod kaigyo = 0 Then '何個おきに改行させるか
            shapeCol = 5
            shapeRow = shapeRow + shapeH
        End If

    'オートシェイプを作成する
    Set myShape = ActiveSheet.Shapes.AddShape(Type:=shapeType, _
        Left:=shapeCol, Top:=shapeRow, Width:=shapeW, Height:=shapeH)

    '文字列を入れる
    myShape.Select
    Selection.Characters.Text = rcode(i)  'A列のみ

        Selection.Font.Name = "ゴシック"
            Selection.Font.Size = 10
            Selection.Font.Bold = True '太字
            Selection.Font.Italic = True
            Selection.ShapeRange.Fill.Transparency = 0
    shapeCol = shapeCol + shapeW

    Next

End Sub

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

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

お試しください

 Option Explicit

 Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long

    Set ws1 = Worksheets("Sheet1")  '勤務表
    Set ws2 = Worksheets("Sheet2")  'オートシェイプ表示

    For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeRectangle Then s.Delete
    Next

    d = Day(Date) + 1
    For i = 3 To 27
        If ws1.Cells(i, d).Value <> "休" Then
            Set c = ws2.Range("K70").Offset(n Mod 2, n \ 2)
            With ws2.Shapes.AddShape( _
                    msoShapeRectangle, c.Left, c.Top, c.Width, c.Height)
                .TextFrame.Characters.Text = ws1.Cells(i, 1).Value
            End With
            n = n + 1
        End If
    Next

 End Sub

（マナ） 2016/04/09(土) 23:49

 こんにちは。

 これ、どこかのシートのＡ列に出勤のかたの氏名をずらっと並べたら
 そのシートを対象にマクロを動かして、やりたいことが実現しますよね。
 （ここまで理解できるでしょうか？）

 で、元の表がこういう形なら、オートフィルタで「休暇以外」を表示できるので
 フィルタを掛けて氏名の列を別のシートのＡ列にコピペすれば
 あとは現在のマクロにまかせれば、うまくいく、、、、かな？　まあ うまく行く方向です。　
 若干の調整は必要かも知れませんが。

 手作業のままではなんなので。
 何度か試して調整がうまく行っていると確認できたら、
 前半の操作を記録マクロのコードにすれば、いいんじゃないかなと思います。
 たぶんここでも若干の調整が必要。でも、調整ならすでに経験しているので。

 こういうのは、うまく行く方向へ うまく行く方向へと少しずつ進んでいくのがいいです。
 少しずつ進めば、小さな達成感がいっぱい経験できて、気分がいいし、実力もつきます。

（　佳　） 2016/04/10(日) 08:29

マナ様

ご教授有難うございます。
凄くスッキリしていていますね。
オートシェイプはSeet1の表に表示させたいの、図形の色と文字色
も設定していので、少し変更してみました。

 Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long

    Set ws1 = Worksheets("Sheet2")  '勤務表
    Set ws2 = Worksheets("Sheet1")  'オートシェイプ表示

    For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeRectangle Then s.Delete
    Next

    d = Day(Date) + 1
    For i = 3 To 25
        If ws1.Cells(i, d).Value <> "休" Then
            Set c = ws2.Range("K70").Offset(n Mod 2, n \ 2)
            With ws2.Shapes.AddShape( _
                    msoShapeRectangle, c.Left, c.Top, c.Width, c.Height)
                .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 10
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .TextFrame.Characters.Font.Bold = True
       .Fill.ForeColor.RGB = vbRed
       .Fill.Transparency = 0
       .Line.Weight = 1

                End With
            n = n + 1
        End If
    Next

End Sub

としました。
本日、１０日の勤務表に合わせた結果、特に問題無く、勤務者のみ表示されました。
VBAは詳しくないのですが、当日は、d = Day(Date) + 1でしょうか？
+1の部分を教えて下さい。

佳様
ご教授有難うございます。
オートフィルタを使って、試してみたいと思います。

（nao） 2016/04/10(日) 12:12

当日のデータがシートの何列目にあるかは、検索しなくても

 勤務表シートのレイアウトが毎月同じであれば
 名前→１列目
 １日→２列目
 ２日→３列目
   …
 10日→11列目
   …
 30日→31列目
 31日→32列目

+1で列数が求まる。ということです。

（マナ） 2016/04/10(日) 12:59

マナさま

わかりました。
もう一つ、オートシェイプの大きさですが
セルの大きさに合わせるのでは無く、横幅と高さを
設定するには、どのようにすればよいでしょうか？
（nao） 2016/04/11(月) 08:43

 横から失礼します。

 こういう場合はヘルプを見るのが一番の早道です。

https://msdn.microsoft.com/ja-jp/library/office/ff821384.aspx

 これを見ると

            With ws2.Shapes.AddShape( _
                    msoShapeRectangle, c.Left, c.Top, c.Width, c.Height)

 このコードの (  ) 内の引数が、それぞれ何者なのかがわかります。
 そうすると、 c.Width が　横幅、c.Height が高さだということがわかりますね。

 ですから、この２つを希望の大きさにすればよろしいのですよ。

（β） 2016/04/11(月) 09:22

βさま

ご教授有難うございます。

 With ws2.Shapes.AddShape( _
                    msoShapeRectangle, c.Left, c.Top, 150, 60)

に変更で、できました。
（NAO） 2016/04/11(月) 16:31

度々、申し訳ありません。
教えて下さい。

勤務表の「休み」と空欄以外は勤務者として青色でオートシェイプ表示
させていますが、その勤務には早番と遅番と４種類の勤務形態があり
オートシェイプの色分けをしたいと考えております。

例えば
当日の勤務者の中で

早番　= 「A」はオートシェイプ色を青に
早番　= 「B」は赤に

遅番　= 「C」は緑に
遅番　= 「D」は黄色に　　と言った感じで・・・

現在のコードです。

 Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeRoundedRectangle Then s.Delete
    Next

    d = Day(Date) + 1
    For i = 3 To 44
        If ws1.Cells(i, d).Value <> "休" Then
         If ws1.Cells(i, d).Value <> "" Then
            Set c = ws2.Range("AG71").Offset(n Mod 4, n \ 1)
            With ws2.Shapes.AddShape( _
                   msoShapeRoundedRectangle, c.Left, c.Top, 160, 60)
                .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.HorizontalAlignment = xlHAlignCenter
       .TextFrame.VerticalAlignment = xlVAlignCenter
       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 15
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .Fill.ForeColor.RGB = RGB(0, 204, 255)
       .Fill.Transparency = 0
       .Line.Weight = 1

                End With
            n = n + 1
        End If
        End If
    Next

End Sub

よろしくご教示をお願いします。
（nao） 2016/04/12(火) 13:46

単純なIf～thenは理解できているようなので、
複数条件で、処理を変える場合の記述がわからないということでしょうか。

http://www.d3.dion.ne.jp/~jkondou/excelvba/jouken.htm

（マナ） 2016/04/12(火) 21:41

マナさん

すみません。追加、追加で。
うまくオートシェイプが表示されるよになったら、更に見やすく
と思いまして、追加で質問しました。

ですが、VBAは、ほとんどわかりません。時間をかけて、色々調べて
取り入れています。

この追加質問も調べましたが、良くわかりません。Caseとか使い方が
分かりません。
（nao） 2016/04/12(火) 22:15

これは理解できますか

 Sub A1の文字によってB1着色()
    Dim 文字 As String

    文字 = Cells(1, 1).Value

    If 文字 = "A" Then
        Cells(1, 2).Interior.Color = vbRed
    ElseIf 文字 = "B" Then
        Cells(1, 2).Interior.Color = vbBlue
    ElseIf 文字 = "C" Then
        Cells(1, 2).Interior.Color = vbYellow
    Else
        Cells(1, 2).Interior.Color = vbGreen
    End If

 End Sub

（マナ） 2016/04/12(火) 22:37

少しですが・・？

Cell(1,1) つまりA1が文字が入る場所で
A1に"A"が入るとCell(1,2)つまりB1セルが赤に。
"B"であればB1セルが青に。

更に色が多くなるとElseIf文が増えていく。

と言う事でしょうか？
（nao） 2016/04/12(火) 23:11

そうです。

 で条件ごとに、
 .Fill.ForeColor.RGB = vbRed
 みたいに、何色にするか記述すればよいです。

（マナ） 2016/04/12(火) 23:30

マナさん

遅くまで、ご教授ありがとうございます。

ちょっとやってみます。

（nao） 2016/04/12(火) 23:51

 失礼します。
 混乱してしまうかもしれませんが・・

 条件分岐の代表的なものが IF文による制御ですが、Select Case を使う場合もあります。
 もう１つ、コードでは　同一の対象セル記述が複数でてきます。
 仮に、色つけの場所を変更すると、セル記述も複数、修正しなければいけません。

 ということで、以下のような記述方法もありますね。ご参考まで。

 Sub A1の文字によってB1着色2()
    Dim 文字 As String
    Dim 背景色 As Long

    文字 = Cells(1, 1).Value

    Select Case 文字
        Case "A"
            背景色 = vbRed
        Case "B"
            背景色 = vbBlue
        Case "C"
            背景色 = vbYellow
        Case Else
            背景色 = vbGreen
    End Select

    Cells(1, 2).Interior.Color = 背景色

 End Sub

（β） 2016/04/13(水) 08:05

マナさん

お世話になっています。
やってみたものの、うまくいきません。
下記コードです。お願いします。

 Sub TEST()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long
    Dim 文字 As String
   Dim MyColor As Long

    Set ws1 = Worksheets("Sheet2")
    Set ws2 = Worksheets("Sheet1")

    For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeHeart Then s.Delete
    Next

    d = Day(Date + 1) + 1
    For i = 3 To 46
        If ws1.Cells(i, d).Value <> "H" Then
         If ws1.Cells(i, d).Value <> "" Then

    ElseIf 文字 = "A" Then
    MyColor = vbRed

    ElseIf 文字 = "B" Then
     MyColor = vbBlue

      Else
     MyColor = vbYellow

   End If

          Set c = ws2.Range("H71").Offset(n Mod 4, n \ 1)
            With ws2.Shapes.AddShape( _
                 msoShapeHexagon, c.Left, c.Top, 160, 60)
                .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.HorizontalAlignment = xlHAlignCenter
       .TextFrame.VerticalAlignment = xlVAlignCenter
       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 10
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .TextFrame.Characters.Font.Bold = True

       .FiLL.Transparency = 0
       .Line.Weight = 1

                End With
            n = n + 1
        End If

    Next

End Sub

βさま
ご教授有難うございます。
こちらも勉強したいと思います。
（nao） 2016/04/13(水) 10:50

MyColorに色をセットしたようですが、使ってないようですよ？
デバッグは自分でやるように。
（???） 2016/04/13(水) 12:59

皆様、ご教授有難うございます。

下記コードでは青一色しか出ません。

  Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long
    Dim RGB As Long

    Set ws1 = Worksheets("Sheet2")
    Set ws2 = Worksheets("Sheet2")

      For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeHeart Then s.Delete
    Next

   d = Day(Date + 1) + 1
    For i = 3 To 46
        If ws1.Cells(i, d).Value <> "休" Then
         If ws1.Cells(i, d).Value <> "" Then

  If ws1.Cells(i, d) = "A" Then
       RGB = vbRed
    ElseIf ws1.Cells(i, d) = "B" Then
       RGB = vbBlue
    ElseIf ws1.Cells(i, d) = "C" Then
       RGB = vbYellow
    Else
       RGB = vbGreen

     End If

         Set c = ws2.Range("AG71").Offset(n Mod 4, n \ 1)
            With ws2.Shapes.AddShape( _
                 msoShapeHexagon, c.Left, c.Top, 160, 60)
                .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.HorizontalAlignment = xlHAlignCenter
       .TextFrame.VerticalAlignment = xlVAlignCenter
       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 36
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .TextFrame.Characters.Font.Bold = True
       .Fill.Transparency = 0
       .Line.Weight = 1

    End With
            n = n + 1
       End If

      End If
    Next

End Sub

ご教授をお願いします。

（nao） 2016/04/13(水) 16:07

 （???）さんの 2016/04/13(水) 12:59　のコメント、読みましたか？
 最新のコードでは RGB という変数名で、そこに色番号をセットしていますが
 そのRGB を、どこでも使っていないですね？

 色関連では

       .TextFrame.Characters.Font.Color = vbBlack

 無条件に黒（青ではなく黒ですけど）ですね？

（β） 2016/04/13(水) 17:03

βさん

ありがとうございます。

色々と試しましたが、結局
使い方が分かりません。教えて下さい。
よろしくお願いします。
（nao） 2016/04/13(水) 20:21

2016/04/12(火) 13:46時点のコードに戻って考えてみます。
今の問題に関係ないない部分を省略するとこんな感じです。

 １）3行目から44行目まで以下を繰り返す
 ２）当日の列のセルの値が、 "休" でない場合で
 ３）当日の列のセルの値が、 空欄でない場合に
 ４）オートシェイプを挿入
 ５）挿入したオートシェイプの書式を設定（★の行です）

 Sub test()

' （略）

    For i = 3 To 44
        If ws1.Cells(i, d).Value <> "休" Then
            If ws1.Cells(i, d).Value <> "" Then
                '（略）
                With ws2.Shapes.AddShape( _
                        msoShapeRoundedRectangle, c.Left, c.Top, 160, 60)

                    'ここでオートシェイプの書式設定

                    .Fill.ForeColor.RGB = RGB(0, 204, 255)  '★ここが色設定

                End With
                n = n + 1
            End If
        End If
    Next

 End Sub

なので、★の行をifで条件によって実行するように書き換えればよいのです。
こんな感じです。

  If ws1.Cells(i, d) = "A" Then
       .Fill.ForeColor.RGB  = vbRed
    ElseIf ws1.Cells(i, d) = "B" Then
       .Fill.ForeColor.RGB = vbBlue
    ElseIf ws1.Cells(i, d) = "C" Then
       .Fill.ForeColor.RGB = vbYellow
    ElseIf ws1.Cells(i, d) = "D" Then
       .Fill.ForeColor.RGB = vbGreen
     End If

まずは、ここまで理解できますか。
組み込んでみて動作確認してみてください。

（マナ） 2016/04/13(水) 20:46

↑を修正。こうでした。

    If ws1.Cells(i, d).Value = "A" Then
       .Fill.ForeColor.RGB = vbRed
    ElseIf ws1.Cells(i, d).Value = "B" Then
       .Fill.ForeColor.RGB = vbBlue
    ElseIf ws1.Cells(i, d).Value = "C" Then
       .Fill.ForeColor.RGB = vbYellow
    ElseIf ws1.Cells(i, d).Value = "D" Then
       .Fill.ForeColor.RGB = vbGreen
    End If

（マナ） 2016/04/13(水) 21:07

マナさん
ありがとうございます。
なるほどです。ここに組み込むのですね。
変数が定義されていませんとか、コンパイルエラーとか
色々でて、困っておりました。

下記のように組み込みました。

 Sub Test()
   Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long

    Set ws1 = Worksheets("Sheet2")
    Set ws2 = Worksheets("Sheet1")

     For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeHeart Then s.Delete
    Next

   d = Day(Date + 1) + 1
    For i = 3 To 46
        If ws1.Cells(i, d).Value <> "休" Then
         If ws1.Cells(i, d).Value <> "" Then
            Set c = ws2.Range("AG71").Offset(n Mod 4, n \ 1)
            With ws2.Shapes.AddShape( _
                 msoShapeHexagon, c.Left, c.Top, 160, 60)

   If ws1.Cells(i, d).Value = "A" Then
       .Fill.ForeColor.RGB = vbRed
    ElseIf ws1.Cells(i, d).Value = "B" Then
       .Fill.ForeColor.RGB = vbBlue
    ElseIf ws1.Cells(i, d).Value = "C" Then
       .Fill.ForeColor.RGB = vbYellow
    ElseIf ws1.Cells(i, d).Value = "D" Then
       .Fill.ForeColor.RGB = vbGreen
    End If

       .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.HorizontalAlignment = xlHAlignCenter
       .TextFrame.VerticalAlignment = xlVAlignCenter
       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 15
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .TextFrame.Characters.Font.Bold = True

       .Fill.Transparency = 0
       .Line.Weight = 1

                End With
            n = n + 1
        End If
        End If
    Next

End Sub

条件で色が変わっています。
出来ています。問題無く。

（nao） 2016/04/13(水) 21:44

では、もう少し修正してみます。
現在のコードは、こんな感じです。

 Sub test()

 '    （略）
    For i = 3 To 44
        If ws1.Cells(i, d).Value <> "休" Then
            If ws1.Cells(i, d).Value <> "" Then
                '（略）

                    If ws1.Cells(i, d).Value = "A" Then
                       .Fill.ForeColor.RGB = vbRed
                    ElseIf ws1.Cells(i, d).Value = "B" Then
                       .Fill.ForeColor.RGB = vbBlue
                    ElseIf ws1.Cells(i, d).Value = "C" Then
                       .Fill.ForeColor.RGB = vbYellow
                    ElseIf ws1.Cells(i, d).Value = "D" Then
                       .Fill.ForeColor.RGB = vbGreen
                    End If

                   '（略）

                End With
                n = n + 1
            End If
        End If
    Next

 End Sub

ws1.Cells(i, d).Valueが何度もでてきます。
こんなときは変数を使うことが多いです。
例えば、myShiftとういう変数を使ってみました。

  Sub test()
    Dim myShift As String     '★

' （略）

    For i = 3 To 44

        myShift = ws1.Cells(i, d).Value     '★

        If myShift <> "休" Then
            If myShift <> "" Then

	'    （略）

理解できたなら、修正してみてください

（マナ） 2016/04/13(水) 22:00

マナさん
色々と、ご教授有難うございます。
なるほど、ws1.Cells(i, d).Valueをmyshiftと言う変数に
置き換えるのですね。
そうする事で、かなりスッキリしました。

下記のように

 Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long
    Dim myShift As String

    Set ws1 = Worksheets("Sheet2")
    Set ws2 = Worksheets("Sheet1")

  For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeHeart Then s.Delete
    Next

   d = Day(Date + 1) + 1
    For i = 3 To 46
    myShift = ws1.Cells(i, d).Value

        If myShift <> "休" Then
         If myShift <> "" Then
            Set c = ws2.Range("AG71").Offset(n Mod 4, n \ 1)
            With ws2.Shapes.AddShape( _
                 msoShapeHexagon, c.Left, c.Top, 160, 60)

              If myShift = "A" Then
       .Fill.ForeColor.RGB = vbRed
    ElseIf myShift = "B" Then
       .Fill.ForeColor.RGB = vbBlue
    ElseIf myShift = "C" Then
       .Fill.ForeColor.RGB = vbYellow
    ElseIf myShift = "D" Then
       .Fill.ForeColor.RGB = vbGreen
    End If

       .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.HorizontalAlignment = xlHAlignCenter
       .TextFrame.VerticalAlignment = xlVAlignCenter
       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 36
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .TextFrame.Characters.Font.Bold = True
       .Fill.Transparency = 0
       .Line.Weight = 1

                End With
            n = n + 1
        End If
        End If
    Next

End Sub
（nao） 2016/04/13(水) 23:11

インデントの使い方がデタラメで非常に見くいです。
コードの意味を考え、同じ階層の行ごとに、行頭を揃えて下さい。

次はここです。

    If myShift = "A" Then
       .Fill.ForeColor.RGB = vbRed
    ElseIf myShift = "B" Then
       .Fill.ForeColor.RGB = vbBlue
    ElseIf myShift = "C" Then
       .Fill.ForeColor.RGB = vbYellow
    ElseIf myShift = "D" Then
       .Fill.ForeColor.RGB = vbGreen
    End If

.Fill.ForeColor.RGBが何度もでできます。
このままでもよいですが、ここも変数を使ってみます。
こんな記述になります。

  Sub test()

    Dim myRGB As Long

    '（略）

    If myShift = "A" Then
       myRGB = vbRed
    ElseIf myShift = "B" Then
       myRGB = vbBlue
    ElseIf myShift = "C" Then
       myRGB = vbYellow
    ElseIf myShift = "D" Then
       myRGB = vbGreen
    End If
   'ここまででは、何色にするか変数myRGBにセットしたでけで、
   'まだ、実際に色が変更されたわけではない

    .Fill.ForeColor.RGB = myRGB   '★???さん、βさんご指摘の箇所はここ

    '（略）

 End Sub

★の行で実際に色を変更しています。

 色がかわらなかった2016/04/13(水) 16:07のコードをよく見てください。
 ★の行に相当する部分がありますか。

 βさんの、2016/04/13(水) 08:05 のコードを見てください。
 ★の行に相当する部分があるのが理解できますか。

ここまで、理解できたら、修正してみてください。
ただし、もし難しいようなら、今のままで全然問題ないです。
何が問題で色が変更されなかったのかを理解して欲しかっただけなので。

（マナ） 2016/04/13(水) 23:29

＞Offset(n Mod 4, n \ 1)

 気になているのですが、問題無いですか？
 問題ないとしたら、

 Offset(n Mod 4, n)

 で、よいです。
 今日はこれで最後です。

（マナ） 2016/04/13(水) 23:39

マナさん

詳しく教えて頂き、感謝です。
確かに、変数にRGBをセットしておいてRGBが何なのか？
が、ありませんでした。勉強になりました。
有難うございました。

下記コードが修正版です。

 Sub test()
  Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim s As Shape
    Dim c As Range
    Dim d As Long
    Dim i As Long
    Dim n As Long
    Dim myRGB As Long
    Dim myShift As String

    Set ws1 = Worksheets("Sheet2)
    Set ws2 = Worksheets("Sheet1")

      For Each s In ws2.Shapes
        If s.AutoShapeType = msoShapeHexagon Then s.Delete

    Next

   d = Day(Date + 1) + 1
    For i = 3 To 46
    myShift = ws1.Cells(i, d).Value

        If myShift <> "休" Then
         If myShift <> "" Then
            Set c = ws2.Range("AG71").Offset(n Mod 4, n)
            With ws2.Shapes.AddShape( _
                 msoShapeHexagon, c.Left, c.Top, 160, 60)

    If myShift = "A" Then
         myRGB = RGB(0, 204, 255)
    ElseIf myShift = "B" Then
             myRGB = RGB(255, 128, 128)
    ElseIf myShift = "C" Then
             myRGB = RGB(204, 255, 204)
    ElseIf myShift = "D" Then
              myRGB = RGB(51, 102, 255)
    End If
       .Fill.ForeColor.RGB = myRGB

       .TextFrame.Characters.Text = ws1.Cells(i, 1).Value

       .TextFrame.HorizontalAlignment = xlHAlignCenter
       .TextFrame.VerticalAlignment = xlVAlignCenter
       .TextFrame.Characters.Font.Color = vbBlack
       .TextFrame.Characters.Font.Size = 15
       .TextFrame.Characters.Font.Name = "HGP創英角ゴシックUB"
       .Fill.Transparency = 0
       .Line.Weight = 1

                End With
            n = n + 1
        End If
     End If
    Next

End Sub

（nao） 2016/04/14(木) 19:35

コメント返信：

[ 一覧(最新更新順) ]

[[20160409205512]] 『自動でオートシェイプ内に文字を入れる』（nao） ページの最後に飛ぶ

[[20160409205512]]　『自動でオートシェイプ内に文字を入れる』（nao）　ページの最後に飛ぶ