excelの入力条件付きドロップダウンリストのマクロの件では

先日SALINGER様、kn1967様に大変お世話になりました。
http://q.hatena.ne.jp/1260883712
セルA1~A5に入力する方法はドロップダウンリスト
リストデータ(例)は、セルC1~C6の値(100,85,70,55,40,25)
とし先日教授戴きましたマクロを改造?して以下の様な
ことをexcelマクロで出来るでしょうか?
例えば、セルA1にて85をドロップダウンリストで選択した場合、
次のセルA2においてのドロップダウンリストの内容は、70,55,40,25
そこでセルA2にて55をドロップダウンリストで選択した場合、
次のセルA3にてのドロップダウンリストの内容は、40,25
必ず、先に入力したセルの値より小さい値を選択入力する様な仕様。
入力順番は、ランダム又はA1→A2…A5固定
リストデータの最小値を入力したセル以降のセルでは、
ドロップダウンリストを表示させない。または空白のリストにする。
ご教授宜しくお願い申し上げます。

回答の条件
  • URL必須
  • 1人5回まで
  • 登録:2009/12/17 13:36:14
  • 終了:2009/12/22 08:16:52

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/12/17 14:12:55

ポイント40pt

例えば25を選択すると次に何も選択できなくなってしまうので

また全部選択できる仕組みいれないといけないですね。

それで、C列に無いデータ(空白など)を入力するとまた100から選択できようにしました。


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
    
    If Columns("C").Find(Target.Value, lookat:=xlWhole) Is Nothing Or Target.Value = "" Then
        j = 1000    'C列よりも大きな数字
    Else
        j = Target.Value
    End If
    
    For i = 1 To 6
        If j > Cells(i, "C").Value Then
            s = s & "," & Cells(i, "C").Value
        End If
    Next i

    Range("A1:A5").Validation.Delete
    
    If s = "" Then s = "ALL"
        
    With Range("A1:A5").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=s
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = False
    End With
End Sub

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

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/12/17 14:12:55ここでベストアンサー

ポイント40pt

例えば25を選択すると次に何も選択できなくなってしまうので

また全部選択できる仕組みいれないといけないですね。

それで、C列に無いデータ(空白など)を入力するとまた100から選択できようにしました。


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
    
    If Columns("C").Find(Target.Value, lookat:=xlWhole) Is Nothing Or Target.Value = "" Then
        j = 1000    'C列よりも大きな数字
    Else
        j = Target.Value
    End If
    
    For i = 1 To 6
        If j > Cells(i, "C").Value Then
            s = s & "," & Cells(i, "C").Value
        End If
    Next i

    Range("A1:A5").Validation.Delete
    
    If s = "" Then s = "ALL"
        
    With Range("A1:A5").Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=s
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = False
    End With
End Sub

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

id:kn1967 No.2

kn1967回答回数2915ベストアンサー獲得回数3012009/12/17 14:29:57

ポイント40pt

Set の2行によって範囲の指定を一箇所に集めて、

前回のものより応用を利かせやすくしてみました。

※最小が入力された時点でドロップダウンリストは出なくなる仕様です。

※最小のセル(25)を消した時点でドロップダウンリストは復活します。

※コメント欄が開いてないので、ここで質問しますが、

 ランダムに書き込んだ際には番号が必ずしも降順にならない仕様です。

 それでよろしいでしょうか?  このあたりの仕様が判らなかったので、

 改良が必要ならコメント欄にでも変更分だけ書き込みますので、お返事ください。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 And Target.Row >= 1 And Target.Row <= 5 Then
        Dim aRange As Range, cRange As Range, c As Range
        Dim pickupList As String, minValue As Long, i As Long
        
        Set aRange = Range("A1:A5")
        Set cRange = Range("C1:C6")
        minValue = Application.WorksheetFunction.min(aRange)
        
        If minValue = Application.WorksheetFunction.min(cRange) Then
            aRange.Validation.Delete
        Else
            pickupList = ""
            For Each c In cRange
                If minValue = 0 Or minValue > c.Value Then
                    pickupList = pickupList & "," & c.Value
                End If
            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
    End If
End Sub

http://dummy.hatena.ne.jp/ダミー

  • id:hawk007
    お礼を申し上げずに、先の質問と
    誤って終了してしまいました。

    まだ教えていただきたいことがありますので
    また、質問申し上げますので何卒よろしくお願い申し上げます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません