エクセルの学校：全文検索：Hyper Estraier：オートシェイプ

Results of 1 - 1 of about 1039 for オートシェイプ (0.001 sec.)

[[20190727062600]]: #score: 6703; @digest: 3ea7e837d862841f04cc9fb11670022d; @id: 80327; @mdate: 2019-07-30T20:32:00Z; @size: 5721; @type: text/plain; #keywords: getshapetosheet (22494), 】| (20310), ィフ (16417), oneinstance02 (12470), フお (12397), unichar (8350), 底完 (7380), アラ (5804), msoshapeoval (4350), lockaspectratio (3323), シェ (3161), トシ (3050), ェイ (2976), 隠居 (2799), addshape (2648), height (2622), イプ (2205), width (2129), forecolor (2091), 到底 (1948), 居じ (1794), 個以 (1791), じー (1730), 距離 (1653), 定可 (1625), オー (1154), 囲み (1067), （ア (985), 2019 (962), shapes (880), worksheetfunction (858), nothing (806); 『特定の文字列のあるセルにオートシェイプで丸を書くマクロ』（アラフィフおやじ）
方眼紙状の表に2桁の数字が並んでいます。ある数字は() や【】で囲まれてます。 ()のセルはオートシェイプの〇で囲みたい【】のセルは塗りつぶした透過〇で囲みたいのですが可能でしょうか? 今は手作業でやっておりますが 100個以上あるし、毎月変わるのでマクロでできないかと相談させていただきました。よろしくお願いします。＜使用 Excel:Excel2013、使用 OS:Windows7 ＞ ---- 結論から言えば可能です。 オートシェイプはマクロで追加することができます。その際、上からの距離、左からの距離、高さ、幅等すべてマクロで設定可能です。また、シート内のセルのうち()や【】を探して、それが存在するセルに対して何かしらの処理を加えることは可能です。つまりシート内のセルを精査 ⇒()や【】があれば位置、セルのサイズを取得 ⇒取得した位置、サイズに合わせてオートシェイプを追加 ⇒すべてのセルになるよう繰り返すという処理で可能になります。ただ、100個もオートシェイプを追加するとちょっとファイルサイズが大きくなり取り回しが悪くなりそうですが。（高橋） 2019/07/27(土) 08:28 ---- ありがとうございます。現在も100個以上のオートシェイプを追加しているので大丈夫だと思ったのですが、マクロだと難しいのですね。（アラフィフおやじ） 2019/07/28(日) 06:46 ---- おはようございます ^^ 回答ではありません新規BOOKにでもコピペしていじってみて下さい。^^;。。。何かの足しにでも ↑ ならなかったらゴミ箱にでも。。。m(_ _)m Option Explicit Sub OneInstance() Dim r As Range Dim y As Long Dim x As Long With Worksheets("Sheet1") x = 2 For y = 2 To 100 + 2 Set r = .Cells(y, x) With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, 72, 72) .LockAspectRatio = True If r.Height < r.Width Then .Height = r.Height Else .Width = r.Width End If End With Next y End With Set r = Nothing End Sub 消すときは ↓ です。 Private Sub SpDelete() Dim Sp As Object For Each Sp In ActiveSheet.Shapes Sp.Delete Next End Sub （隠居じーさん） 2019/07/28(日) 08:16 ---- 隠居じーさんさんありがとうございます。 オートシェイプをマクロで追加する方法がわかりました。検索して、座標をうまく、このマクロに渡せれば出来るということがわかりました。あとは自分で何とかしてみます。（アラフィフおやじ） 2019/07/28(日) 13:55 ---- こんばんは ^^ もう完成されたかもしれませんが。。。作ってみました。なにかの足しにでも ← ならないかも A^_^; Sheet1 に下記の様な情報が有ると仮定して。 |[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] [1] |【32】| | | | | | | | | [2] |【10】| | | | | | |【11】|【12】|【13】 [3] |【20】| | |【30】|【31】|【32】| | | |【99】 [4] | | | | | | | | | | [5] | | | | | | | | | | [6] | | |【45】| | | | | | (25)| [7] | | |【46】| | | | (10)| | (88)| [8] | | |【47】| | | | | | (89)| [9] | | | | | | | | | (90)| [10]| |【22】|【55】|【56】|【66】|【67】|【68】| | (91)| Option Explicit Sub OneInstance02() Dim r As Range Dim WF As Object Set WF = WorksheetFunction With Worksheets("Sheet1") For Each r In .UsedRange Select Case True Case InStr(1, r.Value, WF.Unichar(12304)) <> 0 GetShapeToSheet 1, r Case InStr(1, r.Value, WF.Unichar(40)) <> 0 GetShapeToSheet 0, r End Select Next End With Set r = Nothing Set WF = Nothing End Sub Private Sub GetShapeToSheet(ByVal Flg As Long, ByVal r As Range) Dim Tp As Single With Worksheets("Sheet1") Tp = 0.7 With .Shapes.AddShape(msoShapeOval, r.Left, r.Top, 72, 72) .LockAspectRatio = True If r.Height < r.Width Then .Height = r.Height .Left = r.Left + WorksheetFunction.Round((r.Width - .Width) / 2, 2) Else .Width = r.Width .Top = r.Top + WorksheetFunction.Round((r.Height - .Height) / 2, 2) End If If Flg = 1 Then .Fill.ForeColor.RGB = RGB(255, 255, 0) .Fill.Transparency = Tp End If End With End With End Sub （隠居じーさん） 2019/07/28(日) 18:24 ---- 隠居じーさん様感動しました。 3年間悩んでいたのが一気に解決しました。 If Flg = 0 Then でもう一つのほうも色付けしました。 .Line.ForeColor.RGB で線の色も指定できました。自分だけでは、到底完成できませんでした。本当にありがとうございました。（アラフィフおやじ） 2019/07/29(月) 18:07 ---- こんにちは ^^ 。。。もうご覧になっていないかもしれませんが。よかったですね。なにかの足しには。。。なった様で幸甚です。私も楽しく勉強させていただきました有難うございました。 Sub OneInstance02() の最後から2行目の Set r = Nothing は。。。不要だったと思います。ま!在ってもエラーには成りませんし影響もないと思いますが ^^: For Each 〜を抜けた時点でNothingになっていました。済みません。。。とほほ〜 m(_ _)m でわ（隠居じーさん） 2019/07/30(火) 07:36 ---- 隠居じーさん様フォローありがとうございます。私も、もっと勉強して、この掲示板の質問に答えることができるくらいになりたいと思います。（アラフィフおやじ） 2019/07/31(水) 05:32 ...; https://www.excel.studio-kazu.jp/wiki/kazuwiki/201907/20190727062600.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ