[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Worksheet_BeforeDoubleClickを1つのシートで複数(別の範囲)使いたいです。』(Ran)
こんにちは、初めまして
私は、Ranと申します。VBA勉強中で楽しくやってます。
分からない所があって、初めて投稿しました。皆さん、助けて下さい。
Worksheet_BeforeDoubleClickを1つのシートで複数(別の範囲)使いたいです。
今、コード色々考えたんですが、
コードは、ダブルクリックすると、リストボックス表示し選択出来る仕組みです。
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
1、動作出来ました。範囲は(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
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
2、別の追加(範囲)すると、ダブルクリック出来ない。(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 = "[○] - 午前," & _ "[□] - 午後," & _ "[◎] - 1日," & _ "[休] - 休み," & _ "[取消] - セルのクリア"
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 = "[○] - 午前," & _ "[□] - 午後," & _ "[◎] - 1日," & _ "[休] - 休み," & _ "[取消] - セルのクリア"
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
次に、どこか違っているはずだけど判らない、という場合、デバッグして、原因を探します。 これはコーディングした人のやるべき作業であり、人任せして良いものではありません。 ブレークポイントやステップ実行を使って、思っていたように動いていない箇所を見つけてください。
稲葉さんは、別々の領域を判定するヒントをくれました。 しかしながら、後のコードでもIntersectで領域判定後、領域外ならExitしてしまっています。 これで正しいのですか? Exit Sub している全ての行にブレークポイントを設定し、意図しないところで抜けてしまっている箇所を特定してください。
プログラムを作って、思った通りに動いたときはうれしいのです。しかし、デバッグは面倒だし時間かかるし、嫌な事です。 でも、デバッグしてバグを直さないと、ゴールにたどり着けないので、頑張ってください。
(???) 2017/06/15(木) 16:11
たぶんこうだろうってのを推測してみました。 書き直していて気付いたこと。 1)変数宣言が網羅されていない(buf1など) 2)1回しか使わない変数が定義されている(jなど) 3)マジックナンバーが多すぎ(i - 13など) 4)IF文で否定ばかり繰り返している( <> "取消"は= "取消"にして、取消の場合の処理を記載する 5)Withがないので主語(オブジェクト)が無駄に多い(Activesheetなど) 6)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("[○] - 午前," & _ "[□] - 午後," & _ "[◎] - 1日," & _ "[休] - 休み," & _ "[取消] - セルのクリア", ",") 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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.