[[20101213213341]]　『二つのクリックイベントを一つのシートで行いたい』（Ｍｓｄ）　ページの最後に飛ぶ

『二つのクリックイベントを一つのシートで行いたい』（Ｍｓｄ）

[エクセルのバージョン]Excel2003

[OSのバージョンの例]Windows 7

一つは選択したセルをオートシェイプで囲うコードでもう一つは画像挿入のコードなのですがこれを一つのシートに書くにはどのようにすればいいのでしょうか？
色々試してみて別々では正常に動くのですが二つ入れる事が出来ません

コードは↓

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim sp As Integer, i As Integer, R As Range, B As Boolean

    For Each R In Target

    If Not Intersect(R, Range("L10:AE12,L26:AE28")) Is Nothing Then
        If R.Value = "･" Or R.Value = "" Then GoTo NEXTCODE
            Cancel = True
            B = False
        For i = 1 To Me.Ovals.Count
            If Shapes(i).TopLeftCell.Address = R.Address Then B = True: Exit For
    Next i
        If B Then
                Ovals(i).Delete
        Else
                Set R = R.MergeArea
                With Me.Shapes.AddShape(Type:=msoShapeOval, _
                Left:=R.Left, Top:=R.Top, Width:=R.Width, Height:=R.Height)
                .Fill.Visible = msoFalse
            End With

        End If
    End If
NEXTCODE:
        Exit Sub
    Next R
End Sub
↑これと、↓
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim sp As Integer, i As Integer
    If Intersect(Target, Range("B1:K336")) Is Nothing Then Exit Sub
        With Target
        Cancel = True
        myF = Application.GetOpenFilename _
               ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
            If myF = False Then
                MsgBox "画像を選択してください(終了)"
            Exit Sub
        End If
            For Each mySP In ActiveSheet.Shapes
                myAD1 = mySP.TopLeftCell.MergeArea.Address
                myAD2 = Target.Address
                If myAD1 = myAD2 Then mySP.Delete
            Next
            Set mySP = ActiveSheet.Pictures.Insert(myF)
            myHH = Target.Height / mySP.Height
            myWW = Target.Width / mySP.Width
        If myHH > myWW Then
            mySP.Height = mySP.Height * myWW
            mySP.Width = Target.Width
        Else
            mySP.Height = Target.Height
            mySP.Width = mySP.Width * myHH
        End If
        Set mySP = Nothing
    End With
End Sub
↑です。
色々調べてみたのですが解りませんでした＞＜
どうか御教授ねがいます。

 一つのプロシージャにすることもできますが、こんな感じでできると思います。
 Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    BRC1 Target
    BRC2 Target
 End Sub

 Private Sub BRC1(ByVal Target As Range)
    Dim sp As Integer, i As Integer, R As Range, B As Boolean

    For Each R In Target

    If Not Intersect(R, Range("L10:AE12,L26:AE28")) Is Nothing Then
        If R.Value = "･" Or R.Value = "" Then GoTo NEXTCODE
            Cancel = True
            B = False
        For i = 1 To Me.Ovals.Count
            If Shapes(i).TopLeftCell.Address = R.Address Then B = True: Exit For
    Next i
        If B Then
                Ovals(i).Delete
        Else
                Set R = R.MergeArea
                With Me.Shapes.AddShape(Type:=msoShapeOval, _
                Left:=R.Left, Top:=R.Top, Width:=R.Width, Height:=R.Height)
                .Fill.Visible = msoFalse
            End With

        End If
    End If
NEXTCODE:
        Exit Sub
    Next R
 End Sub
 Private Sub BRC2(ByVal Target As Range)
    Dim sp As Integer, i As Integer
    If Intersect(Target, Range("B1:K336")) Is Nothing Then Exit Sub
        With Target
        Cancel = True
        myF = Application.GetOpenFilename _
               ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
            If myF = False Then
                MsgBox "画像を選択してください(終了)"
            Exit Sub
        End If
            For Each mySP In ActiveSheet.Shapes
                myAD1 = mySP.TopLeftCell.MergeArea.Address
                myAD2 = Target.Address
                If myAD1 = myAD2 Then mySP.Delete
            Next
            Set mySP = ActiveSheet.Pictures.Insert(myF)
            myHH = Target.Height / mySP.Height
            myWW = Target.Width / mySP.Width
        If myHH > myWW Then
            mySP.Height = mySP.Height * myWW
            mySP.Width = Target.Width
        Else
            mySP.Height = Target.Height
            mySP.Width = mySP.Width * myHH
        End If
        Set mySP = Nothing
    End With
 End Sub
 (Mook)

（Ｍｓｄ）

Ｍｏｏｋさん答えていただきありがとうございます。

掲示していただいたコードで出来たのですが幾つか問題が出てしまいました＞＜；

以前のコードではCancel = Trueでメニュー（コンテキストメニュー？）が出ない様になっていたのですがなぜかメニューが出てしまいます＾＾；

Cancel = Trueもちゃんと書かれているのになぜなんでしょう？

それとこれは掲示していただいたコード以前からなのですが、はじめのオートシェイプで選択セルをまるく囲うコードは他のシートでも使っているのですがそっちではちゃんと思ったとおり（クリックでまるく囲って、まるく囲ってあるセルをクリックすると丸が消せる）に動いてくれるのですがこっちのシートではオートシェイプで選択セルをまるく囲う事は出来るのですがもう一度クリックすると丸が消せずにまたまるく囲ってしまいます。又、色々クリックしていると突然違うセルの丸が消えたりもします。

多分コード自体で違うところはRange位だと思うのですが。。。思った通りに動いてくれるシートは

Range("K13:AH48")で変な動きをしてしまうコードはRange("L10:AE12,L26:AE28")でその位しか違いはないと思うのですが。。。

原因不明でネットで調べようと思ったのですが調べようがありませんでした＞＜

NEXTCODE:は関係ないかと思い書きませんが一応コードも載せさせていただきます

思ったとおりに動いてくれるシートのコード↓

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim sp As Integer, i As Integer, R As Range, B As Boolean

    For Each R In Target

    If Not Intersect(R, Range("K13:AH48")) Is Nothing Then
        If R.Value = "･" Or R.Value = "" Then GoTo NEXTCODE
            Cancel = True
            B = False
        For i = 1 To Me.Ovals.Count
            If Shapes(i).TopLeftCell.Address = R.Address Then B = True: Exit For
    Next i
        If B Then
                Ovals(i).Delete
        Else
                Set R = R.MergeArea
                With Me.Shapes.AddShape(Type:=msoShapeOval, _
                Left:=R.Left, Top:=R.Top, Width:=R.Width, Height:=R.Height)
                .Fill.Visible = msoFalse
            End With

        End If
    End If
NEXTCODE:
　　　　・
　　　　・

変な動きをしてしまうシートのコード↓

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean) Dim sp As Integer, i As Integer, R As Range, B As Boolean

    For Each R In Target

    If Not Intersect(R, Range("L10:AE12,L26:AE28")) Is Nothing Then
        If R.Value = "･" Or R.Value = "" Then GoTo NEXTCODE
            Cancel = True
            B = False
        For i = 1 To Me.Ovals.Count
            If Shapes(i).TopLeftCell.Address = R.Address Then B = True: Exit For
    Next i
        If B Then
                Ovals(i).Delete
        Else
                Set R = R.MergeArea
                With Me.Shapes.AddShape(Type:=msoShapeOval, _
                Left:=R.Left, Top:=R.Top, Width:=R.Width, Height:=R.Height)
                .Fill.Visible = msoFalse
            End With

        End If
    End If
NEXTCODE:
　　　　　・
　　　　　・
↑これです。
原因のわかる方御教授願います<m(__)m>

ｎ

 変な動き　の方は良く分かりませんが・・・

 Cancel=True は　Worksheet_BeforeRightClick　イベントプロシージャ内に書かないと意味がありません。

 イベント内でTargetの範囲を判断してからCancelとサブプロシージャをCallするように
 してみてはどうでしょうか？

 あとは、このような使い方には違和感がありますね。
 別のRange型の変数を使うかWithステートメントで良いのでは？

 For Each R In Target
   Set R = R.MergeArea
 Next R

 （ｍｏｍｏ）

momoさん
ご回答いただきありがとうございます。

イベントプロシージャ内にTargetの範囲を書き込ませていただいてCancel=Trueは無事にきくようになりました。

ありがとうございます。

御指摘いただいた所は以前Targetの範囲内にある"・"だけのセルと空白""セルを除外するには（まるで囲わない）様にするのに

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim sp As Integer, i As Integer
　　　　If Not Intersect(Target, Range("K13:AH48")) Is Nothing Then
　　　　If Target.Value = "・" Then

            Exit Sub
        Else
            If Target.Value = "" Then
                Exit Sub
        Else
            With Target
                For i = 1 To Me.Ovals.Count
                If Me.Shapes(i).TopLeftCell.Address = .Cells(1, 1).Address Then: sp = i
            Next i
            Cancel = True
                If sp Then
                    Ovals(sp).Delete
                Else
                    Me.Shapes.AddShape(Type:=msoShapeOval, _
                    Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select
                    Selection.ShapeRange.Fill.Visible = msoFalse
                End If
            End With
        End If
    End If
End If

    If Target.Count <> 1 Then Exit Sub
    If Intersect(Target, Range("B14:C115")) Is Nothing Then Exit Sub
        Cancel = True
        If Target.Value = "□" Then
            Target.Value = "■"
        Else
            If Target.Value = "■" Then
                Target.Value = "□"
        Else
            Exit Sub
        End If
    End If
End Sub
とコードを書いた所型が一致しませんとエラーになってしまい行き詰ってしまった時にネットで質問させていただいたら、

セル範囲であるTargetに対して単一の値である"・"や、""等に対して問い合わせをしているのでエラーとなってしまうので、Taget範囲に対して単一セルでループ(For Each R In Targetで）を掛けてあげれば、エラーは回避できると教えていただきこの様な形になったのですがもっと他の回避方法の方が良かったでしょうか？
何分初心者なのでもっとコードが見やすく出来ればと思っているのですが。。。

（Ｍｓｄ）

変な動きの原因がわかりました。

シート内にテキストがあった事が原因だったみたいです。

Ovals限定でCountしているのに、Shapesをループしているので画像や図形があるとおかしな動きをしてしまっていたみたいです。

お騒がせしました。

また見ていただき考えてくれた方にも感謝いたします。

（Ｍｓｄ）

コメント返信：

[ 一覧(最新更新順) ]

[[20101213213341]] 『二つのクリックイベントを一つのシートで行いたい』（Ｍｓｄ） ページの最後に飛ぶ

[[20101213213341]]　『二つのクリックイベントを一つのシートで行いたい』（Ｍｓｄ）　ページの最後に飛ぶ