[[20050514151949]]　『マクロでオートシェイプを描く』（やん）　ページの最後に飛ぶ

『マクロでオートシェイプを描く』（やん）　

 管理人さん回答者さんいつもお世話になります。

 隣り合うセルに男、女と書き込んであります。

 その男、女を○で囲みたくてオートシェイプの塗りつぶしなしで
 やってますがなんせ1000人以上分あるのでマクロを使ってやりたいのですが・・・

 できればセルを選択して　ダブルクリックで丸が付く
　　　　　　　　　　　　ショートカットで丸が付く←本当はこっちが好ましい

 Googleで調べて　こんなコードを見つけたのですがセルの大きさいっぱいに
 ○が広がってでか過ぎなんです（しかも楕円）
 該当箇所と思われるところを修正し走らせてみたらエラーはでないんですが
 丸がでなくて自考の限界を迎えてしまいました。
 下記コードの修正点でもいいんですができればsubプロシジャーが嬉しいです。

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim CurShape As Shape

    Cancel = True
    For Each CurShape In Shapes
        If CurShape.TopLeftCell.Address = Target.Address Then
            CurShape.Delete
            Exit Sub
        End If
    Next
    With Target
    Shapes.AddShape(msoShapeOval, .Left, .Top, .Width, .Height).Fill.Visible = msoFalse
    End With
End Sub

 msoShapeOval, .Left, .Top, .Width, .HeightをmsoShapeOval, 308.25, 165#, 13.5, 13.5としました。

 すみませんがご教授お願いします

 あとなんで私の質問はフォントがデカいんでしょうか(ToT)

 男と女の文字のフォント１１で、一文字のみ入り左にあるとして、
 Shapes.AddShape(msoShapeOval, .Left + 1.5, .Top + 1.5, 12, 12).Fill.Visible = msoFalse

 このくらいで如何でしょう？

 >あとなんで私の質問はフォントがデカいんでしょうか(ToT)
 書込み用の【プレビュー】下の
 テキスト整形ルールを見るとわかると思いますが、
 半角スペースを入れると整形されますよ～♪

入れないとこんな感じ～

 （キリキ）(〃⌒o⌒)b チョット修正

 ありがとうございます
 なるほど～オフセットをかける要領でいいんですね

 ちょっと値を変えてみたら成功しました。

 昔作ったのがあったので、ちょっと改造してみました。
シートモジュールに
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim MyShape As Shape
Cancel = True
If Intersect(Target, Range("A1:D5")) Is Nothing Then Exit Sub
    With Target
        Set MyShape = Me.Shapes.AddShape(msoShapeOval, _
            .Left + (.Width / 4), .Top, (.Width / 4) * 2, .Height)
            MyShape.Fill.Visible = msoFalse
    End With
    With MyShape
        .OnAction = "削除"
    End With
Set MyShape = Nothing
End Sub
標準モジュールに
Option Explicit
Sub 削除()
Dim MyName As String
    MyName = ActiveSheet.Shapes(Application.Caller).Name
    ActiveSheet.Shapes(MyName).Delete
End Sub
失礼！選択しなくても出来ますよねぇ？？？
（SoulMan）

 わっ！削除まで簡単にできてしまうんですね？すごいの一言です。
 マクロの記録からの発展でいけると思っていたので少し悔しいですがｗ

 僕の質問が的を得てなかったのですがこれをすべてのシートに貼り付けるとなると（シート数計50枚）コードの記入も
 マクロ処理したほうが早いですよね？既存のシートなんで
 マクロ入りシートにデータ貼り付けるか、データの方にマクロを
 コピるか。。。

 とにかくありがとうございました

 >これをすべてのシートに貼り付けるとなると（シート数計50枚）
シートモジュールのコードを削除して
↓これをメニューバーのファイルの隣にあるExcelのマークを右クリックしてコード表示させて
そこに貼り付けると全シートで使えますよ？
Option Explicit
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim MyShape As Shape
Cancel = True
If Intersect(Target, Sh.Range("A1:D5")) Is Nothing Then Exit Sub
    With Target
        Set MyShape = Sh.Shapes.AddShape(msoShapeOval, _
            .Left + (.Width / 4), .Top, (.Width / 4) * 2, .Height)
            MyShape.Fill.Visible = msoFalse
    End With
    With MyShape
        .OnAction = "削除"
    End With
Set MyShape = Nothing
End Sub
もう、見てないかな？？
（SoulMan）

 見てますよ～。またまたありがとうございます。
 はじめてこんなところクリックしました、奥が深すぎです(ToT)

 しょ・衝突～

 最初のコードを再利用～♪
 ThisWorkbookに貼付

 Option Explicit
 Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
     Dim CurShape As Shape

     Cancel = True
     For Each CurShape In ActiveSheet.Shapes
         If CurShape.TopLeftCell.Address = Target.Address Then
             CurShape.Delete
             Exit Sub
         End If
     Next
     With Target
         ActiveSheet.Shapes.AddShape(msoShapeOval, .Left + 1.5, .Top + 1.5, 12, 12).Fill.Visible = msoFalse
     End With
 End Sub

 （キリキ）(〃⌒o⌒)b

ありがとうございます。応用力ってあるんですね←感心

 私ならファイルサイズが増加するので、1000個も図形を配置することはしませんが･･･
  (INA)

 う～ん、確かに。。。（ー_ー;）
 （キリキ）(;⌒o⌒)b

 すみません、今までプリントアウトして手書きで○つけていたんですけど
 最近メールでファイルで欲しいと要望が強くこのようなことになってしまいました
 添付できるサイズなら多少は我慢します。
 っていうか他に方法あるんでしょうか？....ちょっと期待

 ということで、1000個作ってみましたぁ(^^;
新規Bookでシートが3枚22.5KBだったのが
167KBになりました。といっても
1000回ダブルクリックしたわけではありませんがぁ(^^;
 あれ？今やったら、
15.5KB→144KBでした。ざっと10倍ですね。。
（SoulMan）

 検証ありがとうございます。10倍ですか・・・
まぁ作業が9割減になればＯＫです。

 例えばSoulManさんのコードを条件によって分ける場合

 Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim MyShape As Shape
Cancel = True
If Intersect(Target, Sh.Range("F8:G27")) Is Nothing Then Exit Sub
    With Target
        Set MyShape = Sh.Shapes.AddShape(msoShapeOval, .Left + 5#, .Top + 18#, 12, 12)
            MyShape.Fill.Visible = msoFalse

    End With 
ElseIf Intersect(Target, Sh.Range("M8:M27")) Is Nothing Then Exit Sub
    With Target
        Set MyShape = Sh.Shapes.AddShape(msoShapeOval, _
            .Left + (.Width / 4), .Top, (.Width / 4) * 2, .Height)
            MyShape.Fill.Visible = msoFalse

    End With
    With MyShape
        .OnAction = "削除"
    End With
Set MyShape = Nothing
End Sub

 としたのですがElseに対するIfがありませんとエラーになってしまいました。
 なぜなんでしょう・・・？そもそもこれは「If　Then  Else」構文では
 ないのでしょうか？

 それは、、、
 >If Intersect(Target, Sh.Range("F8:G27")) Is Nothing Then Exit Sub
  ~~                                                  ~~~~~~~~~~~~~
 ここのIFが１行で終結している為だと思います。
 試しに Exit Sub を取って見たらどうなりますでしょう？
 End If もお忘れなく～♪

 （キリキ）(〃⌒o⌒)b

 早速やってみました。なんとかなりました
 二つの範囲で違うサイズの○がほしくなってお二人のコードを参考に少してを加えました

 結局「～の範囲に無い場合は何もしない」ってコードがかけずじまいですが...
 （やん）

 そういう時は↓一つでいいですよ。
 If Intersect(Target, Sh.Range("F8:G27,M8:M27")) Is Nothing Then Exit Sub
（SoulMan）

 違う範囲にはサイズの違う○が付けたくなったんです。
（SoulMan）さんのコードは「～である時～しない」ってことですよね？
 あれ？違う？
 頭悪くてイヤになります。これでも通勤中や休みの日にはマクロをうまく
 かくために勉強してるんですけど・・・ね
 （やん）

 すみません。全然、見てませんでした(^^;
そんな時はSelectCaseの方がよくないですか？
Option Explicit
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim MyShape As Shape
Cancel = True
If Intersect(Target, Sh.Range("F8:G27,M8:M27")) Is Nothing Then Exit Sub
With Target
    Select Case True
        Case .Row >= 8 And .Row <= 27
            Select Case True
                Case .Column = 6 Or .Column = 7
                    Set MyShape = Sh.Shapes.AddShape( _
                    msoShapeOval, .Left + 5#, .Top + 18#, 12, 12)
                Case .Column = 13
                    Set MyShape = Sh.Shapes.AddShape( _
                    msoShapeOval, .Left + (.Width / 4), .Top, (.Width / 4) * 2, .Height)
            End Select
    End Select
End With
With MyShape
    .Fill.Visible = msoFalse
    .OnAction = "削除"
End With
Set MyShape = Nothing
End Sub
あってるかな？？
（SoulMan）

 完璧です。これでいろんなところに応用できます。
 しっかし（SoulMan）さん（キリキ）さん
 何度もありがとうございます

コメント返信：

[ 一覧(最新更新順) ]

[[20050514151949]] 『マクロでオートシェイプを描く』（やん） ページの最後に飛ぶ

[[20050514151949]]　『マクロでオートシェイプを描く』（やん）　ページの最後に飛ぶ