人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

excelの入力条件付きドロップダウンリストのマクロの件では
SALINGER様、kn1967様に大変お世話になっております。
http://q.hatena.ne.jp/1261024573
先日教授戴きましたマクロを更に改造して以下の様な
ことをexcelマクロで出来るでしょうか?
セルA1?A5に入力する方法はドロップダウンリスト
リストデータ(例)は、セルC1?C6の値(100,85,70,55,40,25)
・入力順番は、A1→A2…A5固定
・リストデータの最小値を入力したセル(EX.A3)以降のセル(EX.A4、A5)では、
自動的に " ― "(又は空白)が入力され、ドロップダウンリスト表示は出なくなる。
・A1?A5の任意にセル上で、マウスの右ボタンを押すと、入力した内容を変更しますか?等
のメッセージを表示し、Yes/No分岐。
yesを選択したときは、A1?A5を自動的にクリアして、ドロップダウンリストがA1に復活し、
A1?A5の入力が可能になる。
ご教授宜しくお願い申し上げます。




●質問者: hawk007
●カテゴリ:コンピュータ
✍キーワード:A1 A3 EX Excel yes
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●27ポイント

A1→A5固定ということで、ドロップダウンリストが表示されるのは入力するセルだけとしました。

一番最初はA1にドロップダウンリストは表示されていないので、右クリックではいを選択してください。


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 If Intersect(Target, Range("A1:A5")) Is Nothing Then Exit Sub
 Cancel = True
 If MsgBox("入力した内容を変更しますか?", vbYesNo + vbQuestion) = vbYes Then
 Application.EnableEvents = False
 With Range("A1:A5")
 .Validation.Delete
 .Clear
 End With
 
 With Range("A1").Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=dList(1000)  '最大よりも大きい数字
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 Application.EnableEvents = True
 End If
End Sub

Private Function dList(j As Integer) As String
 Dim i As Integer
 Dim s As String
 
 For i = 1 To 6
 If j > Cells(i, "C").Value Then
 s = s & "," & Cells(i, "C").Value
 End If
 Next i
 dList = s
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, Range("A1:A5")) Is Nothing Then Exit Sub
 Dim i As Integer
 Dim j As Integer
 Dim s As String
 Dim num As Integer
 
 num = Cells(1, "C").Value
 For i = 2 To 6
 If Cells(i, "C").Value < num Then
 num = Cells(i, "C").Value
 End If
 Next i
 
 If Target.Row < 5 Then
 If Target.Value = num Or Target.Value = "-" Then
 Target.Offset(1, 0).Value = "-"
 Else
 Target.Offset(1, 0).Validation.Delete
 With Target.Offset(1, 0).Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=dList(Target.Value)
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 End If
 End If
 Target.Validation.Delete
End Sub

http://q.hatena.ne.jp/

◎質問者からの返答

SALINGER 様

いつもお世話になっております。

ありがとうございます

?例えば、A1?A5の入力位置を

A15?A19に変更する場合は、

Range("A1:A5")のところをA15:A19にして

If Target.Row < 5 Thenのところの5を19にすればよいのでしょうか?

?C1?C6の値を50.0,25.0,10.0,5.0,2.5,1.25とした場合、プルダウンリストで1.25

を選択すると実行しエラー”1004"が発生してしまうのですが、回避は可能でしょうか?

?C1?C6の値を50.0,25.0,10.0,5.0,2.5,1.25を数値ではなく、文字列として

A1?A5の文字列として表示させることは可能でしょうか?

?このマクロで使用するセルと別途セル単位でロックしない設定をしたセル以外と数式があるセルは保護をかけたい

のですけれど

ActiveSheet.Unprotect Password:="1234”

ActiveSheet.Protectはどこの仕掛ければよいでしょうか?

ご教授よろしくお願い申し上げます。


2 ● SALINGER
●27ポイント ベストアンサー

?と?の変更です。

コードの先頭で入力セルとリストセル範囲を指定できるようにしました。


Const strARange As String = "A1:A5"  '入力セル
Const strCRange As String = "C1:C6"  'リストセル

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 Dim ARange As Range
 Dim CRange As Range
 Set ARange = Range(strARange)
 Set CRange = Range(strCRange)
 If Intersect(Target, ARange) Is Nothing Then Exit Sub
 Cancel = True
 If MsgBox("入力した内容を変更しますか?", vbYesNo + vbQuestion) = vbYes Then
 Application.EnableEvents = False
 ActiveSheet.Unprotect Password:="1234"
 With ARange
 .Locked = False
 .Validation.Delete
 .ClearContents
 End With
 
 With Cells(ARange.Row, ARange.Column).Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=dList(Application.WorksheetFunction.Max(CRange) + 1)
 ActiveSheet.Protect
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 Application.EnableEvents = True
 End If
End Sub

Private Function dList(j As Double) As String
 Dim s As String
 Dim r As Range
 For Each r In Range(strCRange)
 If j > r.Value Then
 s = s & "," & r.Value
 End If
 Next
 dList = s
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim ARange As Range
 Dim CRange As Range
 Set ARange = Range(strARange)
 Set CRange = Range(strCRange)
 If Intersect(Target, ARange) Is Nothing Then Exit Sub
 Dim s As String
 Dim num As Double
 Dim r As Range
 
 num = Application.WorksheetFunction.Min(CRange)
 
 If Target.Row < ARange.Row + ARange.Count - 1 Then
 If Target.Value = num Or Target.Value = "-" Then
 Target.Offset(1, 0).Value = "-"
 Else
 s = dList(Target.Value)
 If s = "" Then
 Target.Offset(1, 0).Value = "-"
 Else
 Target.Offset(1, 0).Validation.Delete
 With Target.Offset(1, 0).Validation
 ActiveSheet.Unprotect Password:="1234"
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=s
 ActiveSheet.Protect
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 End If
 End If
 End If
 Target.Validation.Delete
End Sub

?の文字列の場合です。

Const strARange As String = "A1:A6"  '入力セル
Const strCRange As String = "D1:D5"  'リストセル

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 Dim ARange As Range
 Dim CRange As Range
 Dim s As String
 Set ARange = Range(strARange)
 Set CRange = Range(strCRange)
 If Intersect(Target, ARange) Is Nothing Then Exit Sub
 Cancel = True
 If MsgBox("入力した内容を変更しますか?", vbYesNo + vbQuestion) = vbYes Then
 Application.EnableEvents = False
 ActiveSheet.Unprotect Password:="1234"
 With ARange
 .Locked = False
 .Validation.Delete
 .ClearContents
 End With
 
 s = dList()
 If s <> "" Then
 With Cells(ARange.Row, ARange.Column).Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=dList()
 ActiveSheet.Protect
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 Else
 MsgBox "リストが設定されていません"
 End If
 Application.EnableEvents = True
 End If
End Sub

Private Function dList() As String
 Dim s As String
 Dim r As Range
 For Each r In Range(strCRange)
 If Range(strARange).Find(r.Value, lookat:=xlWhole) Is Nothing Then
 s = s & "," & r.Value
 End If
 Next
 dList = s
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim ARange As Range
 Dim CRange As Range
 Set ARange = Range(strARange)
 Set CRange = Range(strCRange)
 If Intersect(Target, ARange) Is Nothing Then Exit Sub
 Dim s As String
 Dim r As Range
 
 If Target.Row < ARange.Row + ARange.Count - 1 Then
 If Target.Value = "-" Then
 Target.Offset(1, 0).Value = "-"
 Else
 s = dList()
 If s = "" Then
 Target.Offset(1, 0).Value = "-"
 Else
 Target.Offset(1, 0).Validation.Delete
 With Target.Offset(1, 0).Validation
 ActiveSheet.Unprotect Password:="1234"
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=s
 ActiveSheet.Protect
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 End If
 End If
 End If
 Target.Validation.Delete
End Sub

※コード中エラーで止まった後、右クリックしてもメッセージボックスがでない場合、

一時的にイベントが起こらなくなっている可能性があります。

そのときはイミディエイトウィンドウに以下を入力してエンターを押してください。

Application.EnableEvents =True

id:kn1967 さんのコードを参考にさせて頂きました。ありがとうございました。

http://q.hatena.ne.jp/

◎質問者からの返答

SALINGER 様

いつもお世話になっております。

コードの先頭で入力セルとリストセル範囲を指定

できるようにして頂き、大変移植が容易になりました。

ありがとうございます。


3 ● kn1967
●26ポイント

(1)本文

Option Explicit
Const aRangeFormula = "A15:A19", cRangeFormula = "C1:C6"

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 Cancel = True
 If Intersect(Target, Range(aRangeFormula)) Is Nothing Then Exit Sub
 If MsgBox("入力した内容を全てクリアしますか?", vbYesNo + vbQuestion) = vbYes Then
 Range(aRangeFormula).Value = ""
 End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, Range(aRangeFormula)) Is Nothing Then Exit Sub
 
 Dim tValue As Double
 Dim aRange As Range, a As Range, aMinValue As Double
 Dim cRange As Range, c As Range, cMinValue As Double
 Dim pickupList As String
 
 Set aRange = Range(aRangeFormula)
 Set cRange = Range(cRangeFormula)
 tValue = CDbl(Target(1, 1).Value)
 cMinValue = Application.WorksheetFunction.min(cRange)

 Application.EnableEvents = False
 If (Trim(Target(1, 1).Value) <> "") And (tValue = cMinValue) Then
 aRange.Validation.Delete
 For Each a In aRange
 If a.Value = "" Then a.Value = "--"
 Next
 Else
 aMinValue = Application.WorksheetFunction.Max(cRange) + 1
 For Each a In aRange
 If a.Value = "--" Then
 a.Value = ""
 ElseIf (a.Value <> "") And (CDbl(a.Value) < aMinValue) Then
 aMinValue = Val(a.Value)
 End If
 Next
 pickupList = ""
 For Each c In cRange
 If c.Value < aMinValue Then pickupList = pickupList & ",'" & c.Value
 Next
 pickupList = Mid(pickupList, 2)
 With aRange.Validation
 .Delete
 ActiveSheet.Unprotect Password:="aiueo"
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=pickupList
 ActiveSheet.Protect
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 End If
 Application.EnableEvents = True
End Sub

※回答1への返答欄で追加された4項目には対応済みです。

範囲を変える場合は2行目の値を変えてください。

ただし、複数列に渡る指定には未対応です。

※独自に途中まで作ってあったものに手を加えたため

SALINGER さんとは変数名が異なります。

※Option Explicit はコード入力ミスを避けるため書いてありますが、

無くても結構です。


(2)おまけ

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If (Intersect(Target, Range(aRangeFormula)) Is Nothing) Then Exit Sub
 If Target(1, 1).Row = Range(aRangeFormula)(1, 1).Row Then Exit Sub
 If Target(1, 1).Offset(-1, 0).Value = "" Then
 MsgBox ("未記入のセルがあります。必ず上から順番に値を埋めてください。")
 ElseIf Target(1, 1).Offset(1, 0).Value <> "" Then
 MsgBox ("下のセルが入力済みです。" & vbCrLf _
 & "変更する場合は下のセルを一旦削除してください。")
 End If
End Sub

※セル選択時に独自の規制を設けるための布石となるオプションです。

今の所は不要だと思いますが、一応。


http://q.hatena.ne.jp/URL必須という項目ははずしておいてもらえると嬉しい。

◎質問者からの返答

kn1967様

いつもお世話になっております。

おまけで教授いだきましたセル選択時に独自の規制を

設けるためのマクロを活用させて戴きます。

ありがとうございます。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ