[[20190727062600]]　『特定の文字列のあるセルにオートシェイプで丸を書』（アラフィフおやじ）　ページの最後に飛ぶ

『特定の文字列のあるセルにオートシェイプで丸を書くマクロ』（アラフィフおやじ）

方眼紙状の表に2桁の数字が並んでいます。
ある数字は() や【】で囲まれてます。
()のセルはオートシェイプの〇で囲みたい
【】のセルは　塗りつぶした透過〇で囲みたいのですが可能でしょうか？
今は手作業でやっておりますが
100個以上あるし、毎月変わるのでマクロでできないかと相談させていただきました。よろしくお願いします。

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

結論から言えば可能です。

オートシェイプはマクロで追加することができます。
その際、上からの距離、左からの距離、高さ、幅等すべてマクロで設定可能です。

また、シート内のセルのうち()や【】を探して、それが存在するセルに対して何かしらの処理を加えることは可能です。

つまり
シート内のセルを精査
⇒()や【】があれば位置、セルのサイズを取得
⇒取得した位置、サイズに合わせてオートシェイプを追加
⇒すべてのセルになるよう繰り返す
という処理で可能になります。

ただ、100個もオートシェイプを追加するとちょっとファイルサイズが大きくなり取り回しが悪くなりそうですが。
（高橋） 2019/07/27(土) 08:28

ありがとうございます。
現在も100個以上のオートシェイプを追加しているので
大丈夫だと思ったのですが、マクロだと難しいのですね。

（アラフィフおやじ） 2019/07/28(日) 06:46

 おはようございます　＾＾　回答ではありません
新規ＢＯＯＫにでもコピペしていじってみて下さい。＾＾；。。。何かの足しにでも
　　↑　ならなかったら　ゴミ箱にでも。。。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

隠居じーさん様　感動しました。
３年間悩んでいたのが一気に解決しました。
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

コメント返信：

[ 一覧(最新更新順) ]

[[20190727062600]] 『特定の文字列のあるセルにオートシェイプで丸を書』（アラフィフおやじ） ページの最後に飛ぶ

[[20190727062600]]　『特定の文字列のあるセルにオートシェイプで丸を書』（アラフィフおやじ）　ページの最後に飛ぶ