Results of 1 - 1 of about 1039 for オートシェイプ (0.001 sec.)
- [[20160409205512]]
- #score: 6703
- @digest: 781d3406e09f46e8e7ff7cb895071940
- @id: 70422
- @mdate: 2016-04-14T10:35:01Z
- @size: 26189
- @type: text/plain
- #keywords: myshift (187051), textframe (79563), myrgb (46416), クub (44981), 角ゴ (43390), msoshapehexagon (38319), 創英 (38266), 英角 (38266), forecolor (32424), characters (29257), vbgreen (28594), autoshapetype (26268), 休a (25516), xlhaligncenter (22388), 休" (21538), fill (19034), vbblack (18149), transparency (17107), vbyellow (15981), addshape (15891), msoshaperectangle (14983), vbblue (14797), シェ (13098), 字= (13069), ェイ (12332), rgb (10583), verticalalignment (9869), elseif (9734), ws1 (9523), イプ (9139), ゴシ (8342), トシ (7847)
- 『自動でオートシェイプ内に文字を入れる』（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に平成28年4月が入ります。 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 ---- こんにちは。 これ、どこかのシートのA列に出勤のかたの氏名をずらっと並べたら そのシートを対象にマクロを動かして、やりたいことが実現しますよね。 （ここまで理解できるでしょうか?） で、元の表がこういう形なら、オートフィルタで「休暇以外」を表示できるので フィルタを掛けて氏名の列を別のシートのA列にコピペすれば あとは現在のマクロにまかせれば、うまくいく、、、、かな? まあ うまく行く方向です。 若干の調整は必要かも知れませんが。 手作業のままではなんなので。 何度か試して調整がうまく行っていると確認できたら、 前半の操作を記録マクロのコードにすれば、いいんじゃないかなと思います。 たぶんここでも若干の調整が必要。でも、調整ならすでに経験しているので。 こういうのは、うまく行く方向へ うまく行く方向へと少しずつ進んでいくのがいいです。 少しずつ進めば、小さな達成感がいっぱい経験できて、気分がいいし、実力もつきます。 （ 佳 ） 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 としました。 本日、10日の勤務表に合わせた結果、特に問題無く、勤務者のみ表示されました。 VBAは詳しくないのですが、当日は、d = Day(Date) + 1でしょうか? +1の部分を教えて下さい。 佳様 ご教授有難うございます。 オートフィルタを使って、試してみたいと思います。 （nao） 2016/04/10(日) 12:12 ---- 当日のデータがシートの何列目にあるかは、検索しなくても 勤務表シートのレイアウトが毎月同じであれば 名前→1列目 1日→2列目 2日→3列目 … 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 が高さだということがわかりますね。 ですから、この2つを希望の大きさにすればよろしいのですよ。 （β） 2016/04/11(月) 09:22 ---- ---- βさま ご教授有難うございます。 With ws2.Shapes.AddShape( _ msoShapeRectangle, c.Left, c.Top, 150, 60) に変更で、できました。 （NAO） 2016/04/11(月) 16:31 ---- ----- 度々、申し訳ありません。 教えて下さい。 勤務表の「休み」と空欄以外は勤務者として青色でオートシェイプ表示 させていますが、その勤務には早番と遅番と4種類の勤務形態があり オートシェイプの色分けをしたいと考えております。 例えば 当日の勤務者の中で 早番 = 「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 を使う場合もあります。 もう1つ、コードでは 同一の対象セル記述が複数でてきます。 仮に、色つけの場所を変更すると、セル記述も複数、修正しなければいけません。 ということで、以下のような記述方法もありますね。ご参考まで。 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時点のコードに戻って考えてみます。 今の問題に関係ないない部分を省略するとこんな感じです。 1）3行目から44行目まで以下を繰り返す 2）当日の列のセルの値が、 "休" でない場合で 3）当日の列のセルの値が、 空欄でない場合に 4）オートシェイプを挿入 5）挿入したオートシェイプの書式を設定（★の行です） 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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201604/20160409205512.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97013 documents and 608132 words.
訪問者：