[[20170614102551]]　『Worksheet_BeforeDoubleClickを１つのシートで複吹x（Ran）　ページの最後に飛ぶ

『Worksheet_BeforeDoubleClickを１つのシートで複数（別の範囲）使いたいです。』（Ran）

こんにちは、初めまして

私は、Ranと申します。ＶＢＡ勉強中で楽しくやってます。

分からない所があって、初めて投稿しました。皆さん、助けて下さい。

Worksheet_BeforeDoubleClickを１つのシートで複数（別の範囲）使いたいです。

今、コード色々考えたんですが、

コードは、ダブルクリックすると、リストボックス表示し選択出来る仕組みです。

〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

１、動作出来ました。範囲は（O7：AV31）です。

・シートモジュール
Option Explicit

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim myListBox As ListBox
    Dim xRange As Range
    Dim myArray, ws As Worksheet
    Dim myListArray() As String
    Dim i As Long, j As Long, k As Long
    Dim buf
    On Error Resume Next
    ActiveSheet.Shapes("myList").Delete
    On Error GoTo 0
    i = Cells(Rows.Count, 2).End(xlUp).Row
    If i = 4 Then Exit Sub
    Set xRange = Cells(7, "O").Resize(i - 13, 34)
    If Intersect(Target, xRange) Is Nothing Then Exit Sub

    buf = "[体]　- 体育館," & _
          "[運]　- 運動場," & _
          "[柔]　- 柔道場," & _
          "[プ]　- プール場," & _
          "[陸]　- 陸上場," & _
          "[合]　- 合気道場," & _
          "[取消]　- セルのクリア"

    myArray = Split(buf, ",")
    j = UBound(myArray)
    Set xRange = Target.Offset(1)
    Set myListBox = ActiveSheet.ListBoxes.Add( _
                    xRange.Left, xRange.Top, 150, j * xRange.Height)
    myListBox.Name = "myList"
    myListBox.OnAction = "'SubListClick'"
    myListBox.AddItem myArray
    Set myListBox = Nothing
 End Sub
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "myList" Then shp.Delete
    Next shp
 End Sub

・標準モジュール
Sub SubListClick()

    Dim buf
    Dim xRange As Range
    On Error GoTo exit_sub
    buf = ActiveSheet.ListBoxes("myList").List(ActiveSheet.ListBoxes("myList").Value)
    On Error GoTo 0

     '連続回避
    If buf Like "*体*" Then
        If ActiveCell.Offset(, -1).Value Like "*体*" Then
            MsgBox "体育館連続は避けてください", vbCritical + vbOKOnly, "警告"
            Exit Sub
        End If

    If Not (buf Like "*]*") Then
        Exit Sub
    ElseIf buf Like "*変無*" Then
        ActiveSheet.Shapes("myList").Delete
        Exit Sub
    ElseIf Mid(buf, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(buf, 2, 1)
        ActiveCell.Font.ColorIndex = 1  '黒
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    ActiveSheet.Shapes("myList").Delete
exit_sub:
End Sub

〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

２、別の追加（範囲）すると、ダブルクリック出来ない。（E7:L31）

・シートモジュール
Option Explicit

 Private Sub Worksheet1_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim myListBox As ListBox
    Dim mxListBox As ListBox

    Dim xRange As Range
    Dim yRange As Range

    Dim myArray, ws As Worksheet
    Dim mxArray, ws As Worksheet

    Dim myListArray() As String
    Dim mxListArray() As String

    Dim i As Long, h As Long, j As Long, k As Long

    Dim buf1
    Dim buf2

    On Error Resume Next
    ActiveSheet.Shapes("myList").Delete
    On Error GoTo 0
    i = Cells(Rows.Count, 2).End(xlUp).Row
    If i = 4 Then Exit Sub
    Set xRange = Cells(7, "O").Resize(i - 13, 34)
    If Intersect(Target, xRange) Is Nothing Then Exit Sub

    buf1 = "[体]　- 体育館," & _
           "[運]　- 運動場," & _
           "[柔]　- 柔道場," & _
           "[プ]　- プール場," & _
           "[陸]　- 陸上場," & _
           "[合]　- 合気道場," & _
           "[取消]　- セルのクリア"

    myArray = Split(buf1, ",")
    j = UBound(myArray)
    Set xRange = Target.Offset(1)
    Set myListBox = ActiveSheet.ListBoxes.Add( _
                    xRange.Left, xRange.Top, 150, j * xRange.Height)
    myListBox.Name = "myList"
    myListBox.OnAction = "'SubListClick'"
    myListBox.AddItem myArray
    Set myListBox = Nothing

    On Error Resume Next
    ActiveSheet.Shapes("mxList").Delete
    On Error GoTo 0
    h = Cells(Rows.Count, 2).End(xlUp).Row
    If h = 4 Then Exit Sub
    Set yRange = Cells(7, "E").Resize(i - 13, 8)
    If Intersect(Target, yRange) Is Nothing Then Exit Sub

    buf2 = "[○]　- 午前," & _
           "[□]　- 午後," & _
           "[◎]　- １日," & _
           "[休]　- 休み," & _
           "[取消]　- セルのクリア"

    mxArray = Split(buf2, ",")
    k = UBound(mxArray)
    Set yRange = Target.Offset(1)
    Set mxListBox = ActiveSheet.ListBoxes.Add( _
                    yRange.Left, yRange.Top, 150, j * yRange.Height)
    mxListBox.Name = "mxList"
    mxListBox.OnAction = "'SubListClick'"
    mxListBox.AddItem mxArray
    Set mxListBox = Nothing

 End Sub
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "myList" Then shp.Delete
    Next shp
 End Sub

・標準モジュール
Sub SubListClick()

    Dim buf1
    Dim xRange As Range
    On Error GoTo exit_sub
    buf = ActiveSheet.ListBoxes("myList").List(ActiveSheet.ListBoxes("myList").Value)
    On Error GoTo 0

     '連続回避
    If buf Like "*体*" Then
        If ActiveCell.Offset(, -1).Value Like "*体*" Then
            MsgBox "連続は避けてください", vbCritical + vbOKOnly, "警告"
            Exit Sub
        End If

    If Not (buf1 Like "*]*") Then
        Exit Sub
    ElseIf buf Like "*変無*" Then
        ActiveSheet.Shapes("myList").Delete
        Exit Sub
    ElseIf Mid(buf1, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(buf1, 2, 1)
        ActiveCell.Font.ColorIndex = 1  '黒
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    ActiveSheet.Shapes("myList").Delete
exit_sub:
End Sub

Sub SubListClick()

    Dim buf2
    Dim yRange As Range
    On Error GoTo exit_sub
    buf = ActiveSheet.ListBoxes("mxList").List(ActiveSheet.ListBoxes("mxList").Value)
    On Error GoTo 0

     '連続回避
    If buf Like "*休*" Then
        If ActiveCell.Offset(, -1).Value Like "*体*" Then
            MsgBox "休み連続は避けてください", vbCritical + vbOKOnly, "警告"
            Exit Sub
        End If

    If Not (buf2 Like "*]*") Then
        Exit Sub
    ElseIf buf Like "*変無*" Then
        ActiveSheet.Shapes("mxList").Delete
        Exit Sub
    ElseIf Mid(buf2, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(buf2, 2, 1)
        ActiveCell.Font.ColorIndex = 1  '黒
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    ActiveSheet.Shapes("mxList").Delete
exit_sub:
End Sub

エラー出てしまう、助けて下さい。

追加（範囲）するには、どうずればいいでしょうか、、、

ご教示願います。

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

 全部読んでません。

 イベントは複数に分けられないので、イベント発生時の引数を使って分けます。
 この場合、Targetがセルのオブジェクトになりますので、Targetがどこにあるのかで
 処理を分岐します。
 以下の例では、
 A1:A10をダブルクリックした場合、ダブルクリックしたセルにA
 B1:B10をダブルクリックした場合、ダブルクリックしたセルにB
 としています。

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
        Dim r As Range
        Select Case True
            Case Not Intersect(Target, Range("A1:A10")) Is Nothing
                Target.Value = "A"
            Case Not Intersect(Target, Range("B1:B10")) Is Nothing
                Target.Value = "B"
        End Select
    End Sub

 Intersectに関しては、Ranさんの実力があればすぐに理解できるはずです。
 ほかに質問があれば答えます。
 頑張ってください。
（稲葉） 2017/06/14(水) 12:52

稲葉さんへ
返事ありがとうございます。
ヒントありがとうございます、、

少しひらめき出ました。でも

Intersectの意味が分かりますが、コード（下）作成しましたけどやっぱりエラー出てしまうしダブルクリック出来ないです、、

ダブルクリック複数って難しいですね、、

シートモジュール
Option Explicit

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

    Dim myListBox As ListBox

    Dim xRange As Range
    Dim yRange As Range

    Dim myArray, ws As Worksheet

    Dim myListArray() As String

    Dim i As Long, h As Long, j As Long, k As Long

    Dim buf

    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

    On Error Resume Next
    ActiveSheet.Shapes("myList").Delete
    On Error GoTo 0
    i = Cells(Rows.Count, 2).End(xlUp).Row
    If i = 4 Then Exit Sub
    Set xRange = Cells(7, "O").Resize(i - 13, 34)
    If Intersect(Target, xRange) Is Nothing Then Exit Sub

     buf1 = "[体]　- 体育館," & _
           "[運]　- 運動場," & _
           "[柔]　- 柔道場," & _
           "[プ]　- プール場," & _
           "[陸]　- 陸上場," & _
           "[合]　- 合気道場," & _
           "[取消]　- セルのクリア"

    On Error Resume Next
    ActiveSheet.Shapes("myList").Delete
    On Error GoTo 0
    k = Cells(Rows.Count, 2).End(xlUp).Row
    If k = 4 Then Exit Sub
    Set yRange = Cells(7, "E").Resize(k - 13, 8)
    If Intersect(Target, yRange) Is Nothing Then Exit Sub

     buf2 = "[○]　- 午前," & _
           "[□]　- 午後," & _
           "[◎]　- １日," & _
           "[休]　- 休み," & _
           "[取消]　- セルのクリア"

    myArray = Split(buf, ",")
    j = UBound(myArray)
    Set xRange = Target.Offset(1)
    Set yRange = Target.Offset(1)
    Set myListBox = ActiveSheet.ListBoxes.Add( _
                    xRange.Left, xRange.Top, 150, j * xRange.Height)
    Set myListBox = ActiveSheet.ListBoxes.Add( _
                    xRange.Left, yRange.Top, 150, j * xRange.Height)
    myListBox.Name = "myList"
    myListBox.OnAction = "'SubListClick'"
    myListBox.AddItem myArray
    Set myListBox = Nothing

 End Sub
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "myList" Then shp.Delete
    Next shp
 End Sub

標準モジュール
Sub SubListClick()

    Dim buf1
    Dim xRange As Range
    On Error GoTo exit_sub
    buf = ActiveSheet.ListBoxes("myList").List(ActiveSheet.ListBoxes("myList").Value)
    On Error GoTo 0
     '連続回避
    If buf Like "*体*" Then
        If ActiveCell.Offset(, -1).Value Like "*体*" Then
            MsgBox "連続は避けてください", vbCritical + vbOKOnly, "警告"
            Exit Sub
        End If
    If Not (buf1 Like "*]*") Then
        Exit Sub
    ElseIf buf Like "*変無*" Then
        ActiveSheet.Shapes("myList").Delete
        Exit Sub
    ElseIf Mid(buf1, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(buf1, 2, 1)
        ActiveCell.Font.ColorIndex = 1  '黒
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    ActiveSheet.Shapes("myList").Delete
exit_sub:
End Sub
Sub SubListClick() 
    Dim buf2
    Dim yRange As Range
    On Error GoTo exit_sub
    buf = ActiveSheet.ListBoxes("mxList").List(ActiveSheet.ListBoxes("mxList").Value)
    On Error GoTo 0
     '連続回避
    If buf Like "*休*" Then
        If ActiveCell.Offset(, -1).Value Like "*体*" Then
            MsgBox "休み連続は避けてください", vbCritical + vbOKOnly, "警告"
            Exit Sub
        End If
    If Not (buf2 Like "*]*") Then
        Exit Sub
    ElseIf buf Like "*変無*" Then
        ActiveSheet.Shapes("mxList").Delete
        Exit Sub
    ElseIf Mid(buf2, 2, 2) <> "取消" Then
        ActiveCell.Value = Mid(buf2, 2, 1)
        ActiveCell.Font.ColorIndex = 1  '黒
    Else
        ActiveCell.Value = ""
        ActiveCell.Font.ColorIndex = 1
    End If
    ActiveSheet.Shapes("mxList").Delete
exit_sub:
End Sub

ご教示願います。
（Ran） 2017/06/15(木) 13:42

 コードを見てシートのレイアウトまで想像しろっていいたいのですか？
 エラーの内容も聞いてないし、シートモジュールに記載されたコード以外が入ってるかどうかも分からないのにどうしろと？
（稲葉） 2017/06/15(木) 15:23

まず、On Error 文の使用を止めてください。これを使われると、何か間違っていても気づきませんし、予想外の動きになる場合もあります。元シートを見ることができない回答者に余計な負担を掛けることになります。また、On Error Goto を Goto文と同じように使っていますが、大間違いです。こんな書き方をするようだと、当分 On Error文の使用は禁止すべきです。（割り込み処理を全く理解していない！無免許で車を運転しているような怖さを感じます）

次に、どこか違っているはずだけど判らない、という場合、デバッグして、原因を探します。これはコーディングした人のやるべき作業であり、人任せして良いものではありません。ブレークポイントやステップ実行を使って、思っていたように動いていない箇所を見つけてください。

稲葉さんは、別々の領域を判定するヒントをくれました。しかしながら、後のコードでもIntersectで領域判定後、領域外ならExitしてしまっています。これで正しいのですか？ Exit Sub している全ての行にブレークポイントを設定し、意図しないところで抜けてしまっている箇所を特定してください。

プログラムを作って、思った通りに動いたときはうれしいのです。しかし、デバッグは面倒だし時間かかるし、嫌な事です。でも、デバッグしてバグを直さないと、ゴールにたどり着けないので、頑張ってください。
（???） 2017/06/15(木) 16:11

 たぶんこうだろうってのを推測してみました。
 書き直していて気付いたこと。
 １）変数宣言が網羅されていない（buf1など）
 ２）１回しか使わない変数が定義されている（jなど）
 ３）マジックナンバーが多すぎ（i - 13など）
 ４）IF文で否定ばかり繰り返している（ <> "取消"は= "取消"にして、取消の場合の処理を記載する
 ５）Withがないので主語（オブジェクト）が無駄に多い（Activesheetなど）
 ６）Exitが多様されている　Exitしない書き方を覚えないとダメッス。
 以上を踏まえ、書き直してみたので、参考にしてみてください。

 すべてシートモジュール
    Option Explicit
    Const shpName As String = "myList"
    '■■イベント
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
        Dim myAry As Variant
        Select Case True
            Case Not Intersect(Target, Range("O7:AV31")) Is Nothing
                myAry = Split("[体]　- 体育館," & _
                                "[運]　- 運動場," & _
                                "[柔]　- 柔道場," & _
                                "[プ]　- プール場," & _
                                "[陸]　- 陸上場," & _
                                "[合]　- 合気道場," & _
                                "[取消]　- セルのクリア", ",")
                Cancel = True
                Call Me.mkShp(Target, myAry)
            Case Not Intersect(Target, Range("E7:L31")) Is Nothing
                myAry = Split("[○]　- 午前," & _
                                "[□]　- 午後," & _
                                "[◎]　- １日," & _
                                "[休]　- 休み," & _
                                "[取消]　- セルのクリア", ",")
                Cancel = True
                Call Me.mkShp(Target, myAry)
        End Select
    End Sub
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Call Me.DelShp
    End Sub

    '■■プロシジャ
    Sub mkShp(ByVal getTarget As Range, ByVal getAry As Variant)
        With getTarget.Offset(1)
            With Me.ListBoxes.Add(.Left, .Top, 150, UBound(getAry) * .Height * 1.25)
                .Name = shpName
                .OnAction = "'" & ThisWorkbook.Name & "'!" & Me.Name & ".SubListClick"
                .AddItem getAry
            End With
        End With
    End Sub
    Sub DelShp()
        Dim shp As Shape
        For Each shp In Me.Shapes
            If shp.Name = shpName Then shp.Delete
        Next shp
    End Sub

    Sub SubListClick()
        Dim x   As String
        Dim r   As Range
        Set r = ActiveCell
        With Me.ListBoxes(Application.Caller)
            If .Value > 0 Then
                x = .List(.Value)
                x = Mid(x, 2, InStr(1, x, "]") - 2)
                Select Case x
                    Case "取消"
                        r.Value = ""
                        r.Font.ColorIndex = xlAutomatic
                    Case "体", "休"
                        If (r.Offset(, -1) = x) Or (r.Offset(, 1) = x) Then
                            MsgBox x & "連続は避けてください", vbCritical + vbOKOnly, "警告"
                        Else
                            r.Value = x
                            r.Font.ColorIndex = IIf(x = "休", vbRed, xlAutomatic)
                        End If
                    Case Else
                        r.Value = x
                        r.Font.ColorIndex = xlAutomatic
                End Select
                Me.DelShp
            Else
                'リストが選択されてないときの処理
            End If
        End With
    End Sub
 2017/6/16 9:22　差し替えました。

（稲葉） 2017/06/15(木) 19:50

 あー
 左隣しか連続判定してないから片手落ちだね
（稲葉） 2017/06/15(木) 20:12

コメント返信：

[ 一覧(最新更新順) ]

[[20170614102551]] 『Worksheet_BeforeDoubleClickを１つのシートで複吹x（Ran） ページの最後に飛ぶ

[[20170614102551]]　『Worksheet_BeforeDoubleClickを１つのシートで複吹x（Ran）　ページの最後に飛ぶ