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

エクセルでドロップダウンまたはコンボボックスから値を選択するようにしたいのですが、その際にリストのデータに以下のように制限をかけたいのですが、可能でしょうか?
マクロ利用でもかまいませんので教えてください。お礼は300ポイント。

画像を利用して説明します。
詳細はコメントに書きます。

1238245782
●拡大する

●質問者: Ryo0524
●カテゴリ:インターネット ウェブ制作
✍キーワード:エクセル コメント コンボ データ ドロップ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● Mook
●200ポイント

コメントの仕様でマクロを作成してみました。

セルの値が変わった場合、関連セルのリストを動的に変更しています。

各列の100行-140行を作業領域に使用しています。

Private Sub Worksheet_Change(ByVal Target As Range)
 
  '// A1:F4だけを対象
 If Intersect(Target, Range("A1:F4")) Is Nothing Then Exit Sub
  '// 複数セルの変更は無視
 If Target.Count <> 1 Then Exit Sub

 Application.EnableEvents = False
 
 Dim lName As String
 Dim i As Long, j As Long
 
 Dim r As Long, c As Long
 c = Target.Column
 
 Dim res As Range
 Dim subList As Range
 
  '// 各列の100行以降をリスト用の作業列にしよう
 Cells(100, c).Resize(40, 1).Clear
 For i = 1 To 4
 Set subList = Cells(100, c).Offset(10 * (i - 1), 0).Resize(6, 1)
 subList.Value = Cells(17, c).Resize(6, 1).Value
 
 j = subList.Row + subList.Count - 1
 For r = 1 To 4
 If Cells(r, c) <> "" Then
 Set res = subList.Find(Cells(r, c), lookat:=xlWhole)
 If Not res Is Nothing Then
 If res.Value <> Cells(i, c).Value Then
 res.Resize(6, 1).Value = res.Offset(1, 0).Resize(6, 1).Value
 j = j - 1
 End If
 End If
 End If
 Next
  '// リスト用の名前を設定
 lName = "SUB_List" & i & "_" & c
 On Error Resume Next
 ActiveWorkbook.Names(lName).Delete
 On Error GoTo 0
 ActiveWorkbook.Names.Add Name:=lName, RefersToR1C1:="=" & ActiveSheet.Name & "!R" & subList.Row & "C[0]:R" & j & "C[0]"
 
 
  '// 同じ列のセルのリストを設定
 With Cells(i, c)
 .Validation.Delete
 .Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:="=" & lName
 End With
 Next
 Application.EnableEvents = True
End Sub

不明な点はコメントください。

◎質問者からの返答

ありがとうございます。

上記のマクロをエクセルに設定後、A1からA4、B1からB4、…F1からF4にリストボックスを作成するだけでよいのでしょうか?

もし、そうだとしたら、リストボックスは入力規則を使用して作成することで問題ないですか?


2 ● SALINGER
●0ポイント

Validation.Deleteがうまく実行されない可能性もありますが、私の環境では普通にこれでいけました。

初期処理として、最初だけA1に何か書き込むと、リストボックスが生成されます。

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim i As Integer
 Dim str As String
 
 If Intersect(Target, Range("A1:A4")) Is Nothing Then Exit Sub
 If Target.Count <> 1 Then Exit Sub
 
 For i = 1 To 4
 Cells(i, 1).Validation.Delete
 Next
 
 str = ""
 For i = 17 To 22
 If Cells(i, 1).Value <> Range("A1").Value And _
 Cells(i, 1).Value <> Range("A2").Value And _
 Cells(i, 1).Value <> Range("A3").Value And _
 Cells(i, 1).Value <> Range("A4").Value Then
 str = str & Cells(i, 1).Value & ","
 End If
 Next i
 
 For i = 1 To 4
 With Cells(i, 1).Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=Left(str, Len(str) - 1)
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 Next
End Sub
◎質問者からの返答

ありがとうございます。

上記のマクロを設定したのですが、そもそもリストボックスが生成されません…。

たぶんわたしのやり方がおかしいのだとは思いますが・・・。

いまは、上記のマクロを設定後、A1に卒業見込と入力してみました。


3 ● SALINGER
●200ポイント ベストアンサー

図と上のコメントだけで、2つ目のコメントを見てませんでした。

コンボボックスはF列まであるのですね。

その場合少し修正するだけで簡単です。


また、リストが他のシートにある場合でも、真ん中のFor?Nextを変更するだけで可能です。

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim i As Integer
 Dim str As String
 Dim myCol As Long
 
 If Intersect(Target, Range("A1:F4")) Is Nothing Then Exit Sub
 If Target.Count <> 1 Then Exit Sub
 
 myCol = Target.Column
 For i = 1 To 4
 Cells(i, myCol).Validation.Delete
 Next
 
 str = ""
 For i = 17 To 22
 If Cells(i, myCol).Value <> Cells(1, myCol).Value And _
 Cells(i, myCol).Value <> Cells(2, myCol).Value And _
 Cells(i, myCol).Value <> Cells(3, myCol).Value And _
 Cells(i, myCol).Value <> Cells(4, myCol).Value Then
 str = str & Cells(i, myCol).Value & ","
 End If
 Next i
 
 For i = 1 To 4
 With Cells(i, myCol).Validation
 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
 xlBetween, Formula1:=Left(str, Len(str) - 1)
 .IgnoreBlank = True
 .InCellDropdown = True
 .InputTitle = ""
 .ErrorTitle = ""
 .InputMessage = ""
 .ErrorMessage = ""
 .IMEMode = xlIMEModeNoControl
 .ShowInput = True
 .ShowError = True
 End With
 Next
End Sub

最初にコンボボックスを追加するコードも以下を実行させればいいです。

Sub ListInit()
 Dim i As Integer
 For i = 1 To 6
 Cells(1, i).Value = Cells(17, i).Value
 Next
End Sub
◎質問者からの返答

ありがとうございます。

なんとかできました(^_^)

関連質問


●質問をもっと探す●



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