• ベストアンサー
  • 困ってます

【Excel】 数階層のドロップダウンリストを設定

Excel2007を使っています。 B3を分類の「A、B、C」のドロップダウンリストから選択します。 ※別表のG3:G16を元にしますが、「A、A、A、A、A、A、B、B、B・・・」とならないようにしたいです。 また、B3に「A」を選んだ場合、C3に「DDD、EEE、FFF」のドロップダウンが表示され、 C3に「DDD」を選んだ場合、D3に「1001、1002」のドロップダウンが表示され、 いずれかを選択します。 このような入力規制を設定したいのですが、 B3、C3、D3をどのように設定したらよいのか教えて下さい。 宜しくお願いいたします。

共感・応援の気持ちを伝えよう!

  • 回答数9
  • 閲覧数1793
  • ありがとう数2

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.9

#1、2、4、6、7、8、cjです。 #8補足欄へのレスです。 言われてみれば、別シートにある方が自然ですよね。 対応が遅れた感はあります。 変更点を■■で示しました。 入力規則設置するシートのシートモジュール、 まるまる差し替え、です。 ' ' ============================== Option Explicit ' ' ------------------------------ Const イベント範囲 As String = "C9:D20"  '  下位の入力規則を変更するイベント処理対象範囲の参照(2列)■要指定 Const マスタシート名 As String = "Sheet1"  '  マスタテーブルのシート名■■要指定 Const マスタ左上 As String = "V9"  '  マスタテーブル範囲の参照(データ部左上の単セル)■要指定         ' ' ユーザー設定 ↑ ' ' ------------------------------         ' ' 固定 ↓ Const SHOGE As String = "分類" Const SCOMMA As String = ","             ' ' 参照設定する場合◆ : Microsoft Scripting Runtime Private oDict(0 To 2) As Object  '  As Scripting.Dictionary ' ◆ ' ' ------------------------------ Sub 初期設定()  '  マスタ変更時の更新も   Call SetValid End Sub ' ' ------------------------------ Private Sub SetValid(Optional ByVal Target As Range)   Dim sKey As String   Dim sList As String   Dim nFldPos As Long   Dim nOffset As Long   Dim i As Long   If Target Is Nothing Then     Set Target = Range(イベント範囲)     sKey = SHOGE  '  "分類" '    nFldPos = 0& : nOffset = 0&     Range(イベント範囲)(1).Select ' ' ●●   Else     sKey = Target.Value     nFldPos = Target.Column - Range(イベント範囲).Column + 1     nOffset = 1&   End If   Application.EnableEvents = False   On Error GoTo Exit_   If oDict(0) Is Nothing Then Call SetDict   With Target     For i = nFldPos To 2       nOffset = nOffset + 1&       sList = oDict(i)(sKey)  '  ",A,B,C"  ",DDD,EEE,FFF"  ",1001,1002" If sList = "" Then ' ' ● MsgBox Split("分類: 品名:")(i) & sKey & " マッチしません" ' ' ● Application.EnableEvents = True ' ' ● Exit Sub ' ' ● End If ' ' ●       With .Columns(nOffset)         With .Validation           .Delete           .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=sList '          .IgnoreBlank = True '          .InCellDropdown = True         End With         sKey = Split(sList, SCOMMA)(1)  '  "A"  "DDD"  "1001"         .Value = sKey       End With     Next i   End With Exit_:   Application.EnableEvents = True   If Err Then MsgBox Err & Err.Description, vbExclamation End Sub ' ' ------------------------------ Private Sub SetDict()   Dim mtxT()   Dim i As Long '  With Range(マスタ左上)  '  (1/2択)マスタが同一シート上にある場合■■要指定   With Sheets(マスタシート名).Range(マスタ左上)  '  (2/2択)マスタシート名を指定する場合■■要指定     mtxT = .Resize(.End(xlDown).Row - .Row + 1, 3).Value   End With     For i = 0 To 2     Set oDict(i) = CreateObject("Scripting.Dictionary") '    Set oDict(i) = New Scripting.Dictionary ' ◆   Next i   For i = 1 To UBound(mtxT)     If Not oDict(1).Exists(mtxT(i, 1)) Then       oDict(0)(SHOGE) = oDict(0)(SHOGE) & SCOMMA & mtxT(i, 1)       oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲     ElseIf Not oDict(2).Exists(mtxT(i, 2)) Then       oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲     End If     oDict(2)(CStr(mtxT(i, 2))) = oDict(2)(mtxT(i, 2)) & SCOMMA & mtxT(i, 3) ' ' ▲   Next i   Erase mtxT() '' ' ツリー確認用コード '  Dim k1, k2, s2, v0, v1 '  Debug.Print SHOGE, oDict(0)(SHOGE) '  k1 = oDict(1).Keys '  For Each v0 In k1 '    Debug.Print , v0, oDict(1)(v0) '    k2 = Split(oDict(1)(v0), SCOMMA) '    For Each v1 In k2 '      If v1 <> "" Then Debug.Print , , v1, oDict(2)(v1) '    Next '  Next End Sub ' ' ------------------------------ Private Sub Worksheet_Change(ByVal Target As Range)   If Target.Count > 1 Then Exit Sub   If Target.Value = "" Then Exit Sub   If Intersect(Range(イベント範囲).Resize(, 2), Target) Is Nothing Then Exit Sub   Call SetValid(Target) End Sub ' ' ------------------------------ Private Sub Worksheet_Deactivate()   Erase oDict() End Sub ' ' ==============================

共感・感謝の気持ちを伝えよう!

質問者からのお礼

この度は、いろいろと希望に対応下さいましたおかげで、 大変使いやすい表が出来上がりました。 また、カスタマイズしたい部分はありますが、 今回とは別に質問を上げたいと思います。 本当にお世話になりました。

関連するQ&A

  • Excel2010、ドロップダウンリストの問題

    Excel2010のドロップダウンリストについて、もとのリストが編集できず困っています。(実は電話で、そのような相談を受けているのですが) 「校閲」→「入力規則」で設定する画面がありますが、 ここで、「データの入力規則」の「設定」タブで、入力値の種類→「リスト」とし、元の値のところ、ここが「空欄」になっているようです。 にもかかわらず、 その指定のセルはドロップダウンが使えて、リストがちゃんと出てくるようです。 他の情報としては、 ・ドロップダウンのセルの右に出てくる三角マークが表示されない。(本当はドロップダウンを使っていないのではないか、という疑念。あるいは単に表示されない設定にしているだけかもしれません。VBAとか使っているのか) ・セルをクリックすると「ドロップダウンのリンクがなんとか・・」という表示とともに、「実際のリスト自体は表示され、使える」ようです。 ・目的としては、そのリスト自体を「編集」(修正)することです。 データを送ってもらえれば何らかの対処もあるかと思いますが、セキュリティ上の関係でできないようです。 何かヒントでも分かればお願いします。

  • エクセル 入力規則でドロップダウンリストが表示されない

    いつもお世話になります。 エクセル2000の入力規則のリストで、ドロップダウンリストを使って文字を入力したいのですが、ドロップダウンリスト"から選択する"にチェックを入れているのに、何故かドロップダウンのマークが 表示されません。

  • word2007でのドロップダウンリスト操作方法

    word2007を最近使用し始めた者です つい先日まで2003を使用していました 2003でドロップダウンリストを含む 文書テンプレートを作成したのですが 2007でひらいた場合 どのように操作したらドロップダウンリストが使えるようになるのか 分からなくなってしまいました リスト部分をダブルクリックすると ドロップダウンフォームフィールドは表示されるのですが リストが選択できるようにするにはどうすれべいいのでしょうか 教えてください!

その他の回答 (8)

  • 回答No.8

#1、2、4、6、7、cjです。 #7補足欄へのレスです。 > こちらを実行して、リストから選択いたしますと、 > 「1004アプリケーション定義またはオブジェクト定義のエラーです」となります。 > (ただ、アラートが表示されますが処理は正常に行われているようなのです)。 エラーが起こるとすれば、正常終了ではなく 下位の入力規則が設定される前に終了してしまう筈なのですが。 、、という前提で対策を考えてみました。 > ...マスターテーブルの値ですが、... > 実値は、分類に全角文字で学校の名前(○○小学校)などが、 > 品名も全角文字で商品の名前(○○学生服)などが、 > 品番は、全角文字と半角英数字(GSW100EW)などが使われています。 > このあたりの固定をしないといけないのでしょうか。 文字列であれば、まず問題ないです。 特に説明しませんでしたが、入力規則のリスト指定がカンマ区切りですので、 分類、品名、品番、に指定する各セル値に","を使うことはエラーの原因になります。 また、数値や日付値を指定してある場合もエラーに繋がります。 以上の点は意識はしていたものの分類、品名、品番、という項目名からして 対策の必要ないと考えたものです。 でもまぁ数値については、対応しないのも変でしたね。バグ、と呼べなくもない。 セル値が数値でもエラーにならないようにしました。 ' ' ▲ 自分なりに想定の幅を拡げ、十分な対策を施したつもりではいますが、 私の迂闊は珍しくもないので、もし漏れがある場合に 原因を特定する為だけの一時的な(不要になったら削除する)記述を 5行 ' ● マークを付けて示しました。 マクロ側でDictionaryオブジェクトに登録したKeyと セル値とのマッチングがうまく行ってない場合にメッセージを表示しますので 表示されたなら、内容を確認してみてください。それによって対処します。 暫く様子みてみましょう。 > あと、処理後、C9のセルに戻りたいのですが > Range("C9").Select を どこに入れたら良いでしょうか。 追加した記述を ' ' ●● マークを付けて示しました。 処理後、というのが微妙ですが、初期設定後、という解釈です。 > 何度も申し訳ございません。 いいえ。お気になさらず。お互い様です。 こちらも即応レスはできませんが、何とか解決させたいです。 文字数制限に掛かることもあって、ご面倒でしょうが 2つのプロシージャだけ#7について差し換えでお願いします。 ' ' ------------------------------ Private Sub SetValid(Optional ByVal Target As Range)   Dim sKey As String   Dim sList As String   Dim nFldPos As Long   Dim nOffset As Long   Dim i As Long   If Target Is Nothing Then     Set Target = Range(イベント範囲)     sKey = SHOGE  '  "分類" '    nFldPos = 0& : nOffset = 0&     Range(イベント範囲)(1).Select ' ' ●●   Else     sKey = Target.Value     nFldPos = Target.Column - Range(イベント範囲).Column + 1     nOffset = 1&   End If   Application.EnableEvents = False   On Error GoTo Exit_   If oDict(0) Is Nothing Then Call SetDict   With Target     For i = nFldPos To 2       nOffset = nOffset + 1&       sList = oDict(i)(sKey)  '  ",A,B,C"  ",DDD,EEE,FFF"  ",1001,1002" If sList = "" Then ' ' ● MsgBox Split("分類: 品名:")(i) & sKey & " マッチしません" ' ' ● Application.EnableEvents = True ' ' ● Exit Sub ' ' ● End If ' ' ●       With .Columns(nOffset)         With .Validation           .Delete           .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=sList '          .IgnoreBlank = True '          .InCellDropdown = True         End With         sKey = Split(sList, SCOMMA)(1)  '  "A"  "DDD"  "1001"         .Value = sKey       End With     Next i   End With Exit_:   Application.EnableEvents = True   If Err Then MsgBox Err & Err.Description, vbExclamation End Sub ' ' ------------------------------ Private Sub SetDict()   Dim mtxT()   Dim i As Long   With Range(マスタ左上)     mtxT = .Resize(.End(xlDown).Row - .Row + 1, 3).Value   End With      For i = 0 To 2     Set oDict(i) = CreateObject("Scripting.Dictionary") '    Set oDict(i) = New Scripting.Dictionary ' ◆   Next i   For i = 1 To UBound(mtxT)     If Not oDict(1).Exists(mtxT(i, 1)) Then       oDict(0)(SHOGE) = oDict(0)(SHOGE) & SCOMMA & mtxT(i, 1)       oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲     ElseIf Not oDict(2).Exists(mtxT(i, 2)) Then       oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲     End If     oDict(2)(CStr(mtxT(i, 2))) = oDict(2)(mtxT(i, 2)) & SCOMMA & mtxT(i, 3) ' ' ▲   Next i   Erase mtxT() '' ' ツリー確認用コード '  Dim k1, k2, s2, v0, v1 '  Debug.Print SHOGE, oDict(0)(SHOGE) '  k1 = oDict(1).Keys '  For Each v0 In k1 '    Debug.Print , v0, oDict(1)(v0) '    k2 = Split(oDict(1)(v0), SCOMMA) '    For Each v1 In k2 '      Debug.Print , , v1, oDict(2)(v1) '    Next '  Next End Sub ' ' ------------------------------

共感・感謝の気持ちを伝えよう!

質問者からの補足

毎回、迅速かつ正確なご回答に感謝申し上げます。 上記も大変上手く行きました。 ただ、大変申し訳ないのですが、 マスターテーブルの部分を別のシートに設置した場合は、 どうしたらよいでしょうか。 Const マスタ左上 As String = "Sheet1!V9" としても、ダメでした。 最後にこの部分を教えて頂ければ幸いです。 宜しくお願いいたします。

  • 回答No.7

こんにちは。#1、2、4、6、cjです。 #6で触れていた > ...セル範囲の参照を容易に変更できる内容に書き換え... やってみました。 その影響で処理の効率が落ちる面もあるので、その分、 他の部分を見直して補い、トータルでは、前より動作が軽くなっています。 先頭の2カ所だけ、セル範囲を指定すれば、 テーブルの位置を変更した場合にも容易に対応できます。 動作仕様はこれまで提示したものとまったく同じです。 まるまる差し替えで使ってください。 それでは、また。 ' ' ============================== Option Explicit ' ' ------------------------------ Const イベント範囲 As String = "C9:D20"  '  下位の入力規則を変更するイベント処理対象範囲の参照(2列)■要指定 Const マスタ左上 As String = "V9"  '  マスタテーブル範囲の参照(データ部左上の単セル)■要指定         ' ' ユーザー設定 ↑ ' ' ------------------------------         ' ' 固定 ↓ Const SHOGE As String = "分類" Const SCOMMA As String = ","             ' ' 参照設定する場合◆ : Microsoft Scripting Runtime Private oDict(0 To 2) As Object  '  As Scripting.Dictionary ' ◆ ' ' ------------------------------ Sub 初期設定()   Call SetValid End Sub ' ' ------------------------------ Private Sub SetValid(Optional ByVal Target As Range)   Dim sKey As String   Dim sList As String   Dim nFldPos As Long   Dim nOffset As Long   Dim i As Long   If Target Is Nothing Then     Set Target = Range(イベント範囲)     sKey = SHOGE  '  "分類" '    nFldPos = 0& : nOffset = 0&   Else     sKey = Target.Value     nFldPos = Target.Column - Range(イベント範囲).Column + 1     nOffset = 1&   End If   Application.EnableEvents = False   On Error GoTo Exit_   If oDict(0) Is Nothing Then Call SetDict   With Target     For i = nFldPos To 2       nOffset = nOffset + 1&       sList = oDict(i)(sKey)  '  ",A,B,C"  ",DDD,EEE,FFF"  ",1001,1002"       With .Columns(nOffset)         With .Validation           .Delete           .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=sList '          .IgnoreBlank = True '          .InCellDropdown = True         End With         sKey = Split(sList, SCOMMA)(1)  '  "A"  "DDD"  "1001"         .Value = sKey       End With     Next i   End With Exit_:   Application.EnableEvents = True   If Err Then MsgBox Err & Err.Description, vbExclamation End Sub ' ' ------------------------------ Private Sub SetDict()   Dim mtxT()   Dim i As Long   With Range(マスタ左上)     mtxT = .Resize(.End(xlDown).Row - .Row + 1, 3).Value   End With      For i = 0 To 2     Set oDict(i) = CreateObject("Scripting.Dictionary") '    Set oDict(i) = New Scripting.Dictionary ' ◆   Next i   For i = 1 To UBound(mtxT)     If Not oDict(1).Exists(mtxT(i, 1)) Then       oDict(0)(SHOGE) = oDict(0)(SHOGE) & SCOMMA & mtxT(i, 1)       oDict(1)(mtxT(i, 1)) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2)     ElseIf Not oDict(2).Exists(mtxT(i, 2)) Then       oDict(1)(mtxT(i, 1)) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2)     End If     oDict(2)(mtxT(i, 2)) = oDict(2)(mtxT(i, 2)) & SCOMMA & mtxT(i, 3)   Next i   Erase mtxT() '' ' < ツリー確認用 '  Dim k1, k2, s2, v0, v1 '  Debug.Print SHOGE, oDict(0)(SHOGE) '  k1 = oDict(1).Keys 'Split(SHOGE, SCOMMA) '  For Each v0 In k1 '    Debug.Print , v0, oDict(1)(v0) '    k2 = Split(oDict(1)(v0), SCOMMA) '    For Each v1 In k2 '      Debug.Print , , v1, oDict(2)(v1) '    Next '  Next '' ' > End Sub ' ' ------------------------------ Private Sub Worksheet_Change(ByVal Target As Range)   If Target.Count > 1 Then Exit Sub   If Target.Value = "" Then Exit Sub   If Intersect(Range(イベント範囲).Resize(, 2), Target) Is Nothing Then Exit Sub   Call SetValid(Target) End Sub ' ' ------------------------------ Private Sub Worksheet_Deactivate()   Erase oDict() End Sub ' ' ==============================

共感・感謝の気持ちを伝えよう!

質問者からの補足

改訂頂きましてありがとうございます。 #6の方でも、上手く行きました。 確かに、イベント処理対象範囲が変わる可能性が有り、 こちらの改訂版を使えればと思ったのですが、 こちらを実行して、リストから選択いたしますと、 「1004アプリケーション定義またはオブジェクト定義のエラーです」となります。 (ただ、アラートが表示されますが処理は正常に行われているようなのです)。 なお、マスターテーブルの値ですが、質問の際 便宜上、A、DDDD、1001、などといたしましたが、 実値は、分類に全角文字で学校の名前(○○小学校)などが、 品名も全角文字で商品の名前(○○学生服)などが、 品番は、全角文字と半角英数字(GSW100EW)などが使われています。 このあたりの固定をしないといけないのでしょうか。 あと、処理後、C9のセルに戻りたいのですが Range("C9").Select を どこに入れたら良いでしょうか。 何度も申し訳ございません。

  • 回答No.6

#1、2、4、cjです。 #4補足欄へのレスです。 > B3の部分が C9に、 > G3の部分が V9に移動しました。 都合8カ所、セル範囲の参照を直す必要があります。  変更前の記述を先頭に「'」を付けてコメントブロック、  変更後の記述を直下の行に、 示しました。 シートモジュールごと、まるまる、差し替えれば、 移動後の各テーブルに対応しています。 今後も変更の可能性があるならば、 セル範囲の参照を容易に変更できる内容に書き換えた方が いいのかな?と思っています。 一方で、"マスター"を移動する機会は殆どないだろう、という 都合のいい予想もあるので、今回は、 対症療法的な修正だけにとどめます。 (あまりレスが増えても混乱してしまうでしょうし) もし、今後も移動することが想定されるならば、 少しでもメンテし易いものに書き直そうと思います。 その場合は、改めて、別件の質問として来週ぐらいにでも あげてみてください。 設計の異なるアプローチや色んな仕様を試しているうちに 手元では、15バージョン程になってしまい、 混乱している上に、今、私の頭のパフォーマンスが落ちています。 少し時間を空けて欲しいのは、そういう理由です。 やる気はありますので(笑) では、修正済のコードを。 Option Explicit Private oDict As Object ' ' ------------------------------ Private Sub Worksheet_Change(ByVal Target As Range)   If Target.Count > 1 Then Exit Sub   If Target.Value = "" Then Exit Sub '  If Target.Row < 3 Or Target.Row > 14 Then Exit Sub   If Target.Row < 9 Or Target.Row > 20 Then Exit Sub '  If Target.Column > 3 Or Target.Column = 1 Then Exit Sub   If Target.Column > 4 Or Target.Column < 3 Then Exit Sub   Application.EnableEvents = False   On Error GoTo Exit_   Call UniqValid品名品番(Target) Exit_:   Application.EnableEvents = True   If Err Then MsgBox Err & Err.Description, vbExclamation End Sub ' ' ------------------------------ Sub UniqValid品名品番(ByVal Target As Range)   Dim mtxSrc, arrList   Dim sParent As String   Dim i As Long   Dim flg As Boolean '  mtxSrc = Range(Cells(3, Target.Column + 5), Cells(3, Target.Column + 6).End(xlDown)).Value   mtxSrc = Range(Cells(9, Target.Column + 19), Cells(9, Target.Column + 20).End(xlDown)).Value   sParent = Target.Value   On Error GoTo CrDict_   oDict.RemoveAll   On Error GoTo 0   For i = 1 To UBound(mtxSrc)     If mtxSrc(i, 1) = sParent Then       oDict(mtxSrc(i, 2)) = Empty       flg = True     ElseIf flg Then       Exit For     End If   Next i   arrList = oDict.keys   With Target.Offset(, 1)     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = (arrList(0))   End With '  If Target.Column = 2 Then Call UniqValid品名品番(Target.Offset(, 1))   If Target.Column = 3 Then Call UniqValid品名品番(Target.Offset(, 1))   Exit Sub CrDict_:   Set oDict = CreateObject("Scripting.Dictionary")   Resume End Sub ' ' ------------------------------ Sub UniqValid分類_開始()   Dim vSrc, v, arrList '  vSrc = Range("G3", Range("G3").End(xlDown)).Value   vSrc = Range("V9", Range("V9").End(xlDown)).Value   If UBound(vSrc) < 1 Then Exit Sub   Set oDict = CreateObject("Scripting.Dictionary")   For Each v In vSrc     oDict(v) = Empty   Next   arrList = oDict.keys   Application.EnableEvents = False '  With Range("B3")   With Range("C9")     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = arrList(0)   End With '  Call UniqValid品名品番(Range("B3"))   Call UniqValid品名品番(Range("C9")) '  Range("B3:E3").Copy Destination:=Range("B4:B14")   Range("C9:F9").Copy Destination:=Range("C10:C20")   Application.EnableEvents = True End Sub ' ' ------------------------------

共感・感謝の気持ちを伝えよう!

  • 回答No.5
  • tom04
  • ベストアンサー率49% (2537/5117)

No.3です! たびたびごめんなさい。 前回の投稿でSheet2のA~C列の名前定義はしなくても大丈夫のようです。 すなわち前回アップした画像では Sheet2のA1~C1セルのアンダースコア-は必要なく、 そのまま「分類」名を入力しておけば 対応できそうです。 Sheet1のB列の入力規則の「元の値」の欄に =Sheet2!A$1:C$1 という数式を入れるだけで対応できます。 ただし、D列以降はやはり名前定義が必要みたいですね! 実際にExcel2007でOFFSET関数でやってみると やはり別Sheetは参照できないようですので、前回同様名前定義しなくてはならないようです。 ※Excel2010以降であれば名前定義は必要なく、表さえ作成しておけば 元の値の欄に数式を入れるだけで対応できます。 ちゃんと検証せずに投稿してごめんなさいね。m(_ _)m

共感・感謝の気持ちを伝えよう!

質問者からのお礼

おかげさまで、 いろいろな方法が確認できました。 今回は、VBAであっさりとできてしまい (VBAを組んで下さった方は大変だったはず) こちらを使わせて頂くこととしました。 ありがとうございました。

  • 回答No.4

#1、2、cjです。 すみません。#2で、一部ミス(慌てて転載ミス)があって 機能しないものを掲載していました。 Sub UniqValid分類_開始() だけ、まるまる差し替えてくださいませ。 失礼しました。 ' ' ------------------------------ Sub UniqValid分類_開始()   Dim vSrc, v, arrList   vSrc = Range("G3", Range("G3").End(xlDown)).Value   If UBound(vSrc) < 1 Then Exit Sub   Set oDict = CreateObject("Scripting.Dictionary")   For Each v In vSrc     oDict(v) = Empty   Next   arrList = oDict.keys   Application.EnableEvents = False   With Range("B3")     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = arrList(0)   End With   Call UniqValid品名品番(Range("B3"))   Range("B3:E3").Copy Destination:=Range("B4:B14")   Application.EnableEvents = True End Sub ' ' ------------------------------

共感・感謝の気持ちを伝えよう!

質問者からの補足

早速補足下さいましてありがとうございます。 差し替えまして上手く行きました。 もう一点だけ教えて下さい。 実際の票に配置したときに、 B3の部分が C9に、 G3の部分が V9に移動しました。 このとき、Sub UniqValid分類_開始() の Rangeで指定された部分を該当セルに書き換え 以下の通りにしました。 ' ' ------------------------------ Sub UniqValid分類_開始() Dim vSrc, v, arrList vSrc = Range("V9", Range("V9").End(xlDown)).Value If UBound(vSrc) < 1 Then Exit Sub Set oDict = CreateObject("Scripting.Dictionary") For Each v In vSrc oDict(v) = Empty Next arrList = oDict.keys Application.EnableEvents = False With Range("C9") With .Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, Formula1:=Join(arrList, ",") End With .Value = arrList(0) End With Call UniqValid品名品番(Range("C9")) Range("C9:F9").Copy Destination:=Range("C10:C20") Application.EnableEvents = True End Sub ' ' ------------------------------ しかし、これを実行すると、「400」とだけかかれたアラートが出ます。 こんな、単純な対応ではダメでしょうか・・・ この部分だけ、今一度お願いいたします。

  • 回答No.3
  • tom04
  • ベストアンサー率49% (2537/5117)

こんばんは! 超ベタな方法ですが・・・ やり方だけを↓の画像で説明します。(画像が小さかったら拡大してください。) 画像の上側をSheet2・下の右側をSheet3とし、下側左のSheet1にリスト表示させるとします。 表の作成と名前定義に一手間、いや二手間以上しっかり手間をかけます。 画像では頭の分類がアルファベットになっていますね!(実際はアルファベットではないと思いますが) 名前定義する際に数字およびアルファベットの中で使えないものがありますので、 あらかじめアンダースコアー(_)を付けたデータで表を作成しておきます。 (分類名が数値・アルファベット以外であれば頭のアンダースコアーは必要ありません。) (1)Sheet2のA1~C1セルを範囲指定 → 名前ボックスに 仮に 分類 と入力 → Enter これでSheet2のA1~C1セルが「分類」という名前定義されました。 (2)Sheet2のA1以降を範囲指定 → 数式 → 名前の管理 → 選択範囲から作成 → 上端行 → OK B1以降を範囲指定 → ・・・中略・・・(同様に) → OK この操作をSheet2のすべての列で行います。 これでSheet2の色付きセルで名前定義されます。 (3)Sheet3に分類・品名・品番のすべてをアンダースコアーでつないだデータの価格を作成します。 以上の準備ができれば後は簡単です。 Sheet1のB3以降を範囲指定 → データ → データの入力規則 → リスト → 元の値の欄に =分類 としてOK   C3以降を範囲指定 → (同上)・・・中略・・・ → 元の値の欄に =INDIRECT(B3) としてOK D3以降を範囲指定 → (同上)・・・中略・・・ → 元の値の欄に =INDIRECT(B3&"_"&C3) としてOK これで入力規則の設定は完了です。 最後にE3セルに =IF(COUNTBLANK(B3:D3),"",IFERROR(VLOOKUP(B3&"_"&C3&"_"&D3,Sheet3!A:B,2,0),"該当データなし")) という数式を入れオートフィルで下へコピーしておきます。 これで何とかご希望に近い形にならないでしょうか? ※ Exce2010以降であればリストの元の値の欄に数式で別Sheetを指定できますが、 Excel2007ではおそらくダメだったと思います。 そのためこまめに名前定義してみました。 他に良い方法があればごめんなさいね。m(_ _)m

共感・感謝の気持ちを伝えよう!

  • 回答No.2

#1、cjです。 #!補足欄へのレスです。 今あまり時間取れないので取り急ぎ。 扱いは全く同じです。まるごと差し換えで。 プロシージャ、ひとつ減らしました。 それと、ひとつだけ注意点。 '子'リストの自動変更は、B3:C14の範囲内で 単一のセルの値変更があった場合にのみ機能します。 例えば、B3:C14の範囲内の複数セル範囲へ貼り付けした場合などは '子'リストの自動変更は行われない仕様です。 この点の仕様変更が必要なら再レスします。 ただ、次は明日になると思います(今から送別会で遅くなるので)。 ' ' ------------------------------ Option Explicit Private oDict As Object ' ' ------------------------------ Private Sub Worksheet_Change(ByVal Target As Range)   If Target.Count > 1 Then Exit Sub   If Target.Value = "" Then Exit Sub   If Target.Row < 3 Or Target.Row > 14 Then Exit Sub   If Target.Column > 3 Or Target.Column = 1 Then Exit Sub   Application.EnableEvents = False   On Error GoTo Exit_   Call UniqValid品名品番(Target) Exit_:   Application.EnableEvents = True   If Err Then MsgBox Err & Err.Description, vbCritical End Sub ' ' ------------------------------ Sub UniqValid品名品番(ByVal Target As Range)   Dim mtxSrc, arrList   Dim sParent As String   Dim i As Long   Dim flg As Boolean   mtxSrc = Range(Cells(3, Target.Column + 5), Cells(3, Target.Column + 6).End(xlDown)).Value   sParent = Target.Value   On Error GoTo CrDict_   oDict.RemoveAll   On Error GoTo 0   For i = 1 To UBound(mtxSrc)     If mtxSrc(i, 1) = sParent Then       oDict(mtxSrc(i, 2)) = Empty       flg = True     ElseIf flg Then       Exit For     End If   Next i   arrList = oDict.keys   With Target.Offset(, 1)     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = (arrList(0))   End With   If Target.Column = 2 Then Call UniqValid品名品番(Target.Offset(, 1))   Exit Sub CrDict_:   Set oDict = CreateObject("Scripting.Dictionary")   Resume End Sub ' ' ------------------------------ Sub UniqValid分類_開始()   Dim vSrc, v, arrList   vSrc = Range("G3", Range("G3").End(xlDown)).Value   On Error GoTo CrDict_   oDict.RemoveAll   On Error GoTo 0   If UBound(vSrc) < 1 Then     oDict.Add v, Empty   Else     For Each v In vSrc       oDict(v) = Empty     Next   End If   arrList = oDict.keys   Application.EnableEvents = False   With Range("B3")     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = (arrList(0))   End With   Call UniqValid品名((arrList(0)))      Range("B3:E3").Copy Destination:=Range("B4:B14")      Application.EnableEvents = True   Exit Sub CrDict_:   Set oDict = CreateObject("Scripting.Dictionary")   Resume End Sub ' ' ------------------------------

共感・感謝の気持ちを伝えよう!

  • 回答No.1

こんにちは。 VBAによる対応になります。 Sub UniqVal分類_開始() を実行することで初期設定されます。 [分類]を追加|削除した場合は初期設定し直す必要があります。 後は、B3,C3が変更される度に下位のリストを自動的に変更します。 [分類]>[品名]>[品番] '親'側が変更されると、'子'('孫')のリストも変更され、 それぞれ、リストの最上位にある値を仮設定します。 Worksheet_Change イベントを既に使っている場合は 適切な形で組み込み統合する必要があります。 (手に余るようでしたら、既存のコードをご提示の上、ご相談ください) 当該シートのシートモジュールに、 以下、全文、過不足なく、貼付け、Sub UniqVal分類_開始()を実行、保存。 Option Explicit ' ' ------------------------------ Private oDict As Object ' ' ------------------------------ Private Sub Worksheet_Change(ByVal Target As Range)   If Target.Count > 1 Then Exit Sub   If Target.Value = "" Then Exit Sub   If Target.Row <> 3 Then Exit Sub '  If Target.Column > 3 Or Target.Column = 1 Then Exit Sub   If Not Target.Column Like "[23]" Then Exit Sub   Application.EnableEvents = False   On Error GoTo ErrOut_   Select Case Target.Column   Case 2     Call UniqVal品名(Target.Value)   Case 3     Call UniqVal品番(Target.Value)   End Select ErrOut_:   Application.EnableEvents = True   If Err Then MsgBox Err & Err.Description, vbCritical End Sub ' ' ------------------------------ Sub UniqVal品番(sParent As String)   Dim mtxSrc, arrList   Dim i As Long   Dim flg As Boolean   mtxSrc = Range("H3", Range("I3").End(xlDown)).Value   On Error GoTo CrDict_   oDict.RemoveAll   On Error GoTo 0   For i = 1 To UBound(mtxSrc)     If mtxSrc(i, 1) = sParent Then       oDict(mtxSrc(i, 2)) = Empty       flg = True     ElseIf flg Then       Exit For     End If   Next i   arrList = oDict.keys   With Range("D3")     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = (arrList(0))   End With   Exit Sub CrDict_:   Set oDict = CreateObject("Scripting.Dictionary")   Resume End Sub ' ' ------------------------------ Sub UniqVal品名(sParent As String)   Dim mtxSrc, arrList   Dim i As Long   Dim flg As Boolean   mtxSrc = Range("G3", Range("H3").End(xlDown)).Value   On Error GoTo CrDict_   oDict.RemoveAll   On Error GoTo 0   For i = 1 To UBound(mtxSrc)     If mtxSrc(i, 1) = sParent Then       oDict(mtxSrc(i, 2)) = Empty       flg = True     ElseIf flg Then       Exit For     End If   Next i   arrList = oDict.keys   With Range("C3")     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = (arrList(0))   End With   Call UniqVal品番((arrList(0)))   Exit Sub CrDict_:   Set oDict = CreateObject("Scripting.Dictionary")   Resume End Sub ' ' ------------------------------ Sub UniqVal分類_開始()   Dim vSrc, v, arrList   vSrc = Range("G3", Range("G3").End(xlDown)).Value   On Error GoTo CrDict_   oDict.RemoveAll   On Error GoTo 0   If UBound(vSrc) < 1 Then     oDict.Add v, Empty   Else     For Each v In vSrc       oDict(v) = Empty     Next   End If   arrList = oDict.keys   Application.EnableEvents = False   With Range("B3")     With .Validation       .Delete       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _             Operator:=xlBetween, Formula1:=Join(arrList, ",")     End With     .Value = (arrList(0))   End With   Call UniqVal品名((arrList(0)))   Application.EnableEvents = True   Exit Sub CrDict_:   Set oDict = CreateObject("Scripting.Dictionary")   Resume End Sub ' ' ------------------------------

共感・感謝の気持ちを伝えよう!

質問者からの補足

早速のご回答感謝申し上げます。 大変上手く行きました。 ただ、質問のしかたが悪く申し訳ないのですが、 B3:E3の処理を、12行(B14:E14まで)行いたかったのですが、 この場合、単純にセルをコピーしても上手く行きませんでした。 VBAの知識がなく、自分で修正することができません。 補足頂けましたら幸いです。

関連するQ&A

  • Wordでドロップダウンリストを作る時

    こんにちは。 Wordでドロップダウンフォームフィールド機能を使って、 文書内にドロップダウンリストを作成する時、 フォームの保護をかけないとドロップダウンリストが使えないと思うのですが、文書内に他にも手入力する部分がたくさんある場合はどのようにしたらよいのでしょうか。 例えば、氏名、会社名などを入力し、会社の業種などをドロップダウンリスト一覧から選ばせる場合などです。 ドロップダウンリストから選択できるようにすると、 他の項目に入力できないので困っています。 どなたか詳しい方がいらっしゃいましたら教えていただけますでしょうか。よろしくお願いします。

  • ドロップダウンリスト 条件付書式

    エクセル2000です。 ドロップダウンリストで5桁の数字(10000&#65374;39999)を選択する表が作成されています。 このドロップダウンリストの数字を参照して条件付書式を設定することができません。 ドロップダウンを消して直接数字を入力すれば条件どおりに書式が反映されるので条件は間違っていないと思います。 ちなみに条件は以下の通りです。 条件1  =AND(A1>9999,A1<20000)  パターン色 赤 条件2  =AND(A1>19999,A1<30000)  パターン色 緑 条件3  =AND(A1>29999,A1<40000) ドロップダウンでは条件付書式の設定ができないのでしょうか?

  • Excel ドロップダウンリストの書式

    Excel2007 (1) ドロップダウンリストを作ったが、リストの文字が小さくて見にくいので大きく表示出来る方法がありますか? (2) また、12個のリストなのに一時に表示されるのは8番目までで、あとはドロップダウンしなければなりません。12個全て表示する方法がありますか?

  • ホームページビルダーでのドロップダウンリストのリンク方法について

    ホームページビルダーのVer.10でドロップダウンリストを作成しているのですが、 ドロップダウンで選択したものの表示先を、新しいウィンドウにすることは可能でしょうか。 隣接フレームにリンクさせる方法は本などに書かれているのですが、 新しいウィンドウを開けてリンクさせる方法をご存知でしたらお教え下さい。 宜しくお願い致します。

  • Excel97でのドロップダウンリストについて

    セルにドロップダウンリスト(入力規則)を設定したエクセルファイルがあります。このファイルを開けると、セルによってドロップダウンリストが出現するセルと出現しないセルが発生します。 出現するセルと出現しないセルは、いつも同じセルです。なぜリストが出現しないセルがあるのか分かりません。  状況1.WIN98SEにOFFICE97を入れています。  状況2.ファイルが開くときにマクロで書式設定等を行っています。  状況3.マクロを無効にして開くと、全てのリストは出現します。  状況4.OFFICE2000の環境では、正常に全てのリストは出現します。  状況5.そのファイルは何度か手を加えられており、97の環境で作られたか       2000の環境で作られたか分かりません。おそらくもともと97で       作られ、その後2000で手を加えられたと思います。 リストが出現しないというのは、そのセルをクリックしても、ドロップダウンの矢印?が出ず、リストも表示されないというものです。リストの一覧は他のセルに設定してあります。ただ、入力規則は働いており、そのセルには、リストの一覧にある文字しか入力はできません。 どなたか助けてください。お願いします。

  • EXCELのドロップダウンリスト

    いつもありがとうございます。 EXCELでドロップダウンリストを設定したのですが、こちらが考えているように動作せず困っています。 例えばリストが次のようになっているとします。 アメリカ イギリス ウクライナ エチオピア オランダ カナダ キプロス クウェート ケニア コロンビア テキストボックスが空の状態で三角ボタンをクリックすると先頭のアメリカからリストが表示されます。 これを、テキストボックスに "カ" と入れてドロップダウンを開くとカナダから下だけを表示させるようにしたいのですが、うまく動作しません。 そのような事を実現する方法はないのでしょうか? もう一つ、[Alt] + ↓ を押した時に開くドロップダウンメニューにも同様に上記で設定したリストを表示させたいのですがこちらもうまく行きません。

  • コンボボックスでドロップダウンリストにしたときに・・・・

    コンボボックスでドロップダウンリストにしてから実行をすると、最初の項目(一番上)が空白で、その下はリストに書かれてあるように表示されてます。 ドロップダウンしなくても見れるようにするにはどうしたらいのですか? 例: 野菜 ▽    ←ここを表示させたい    みかん    かぼちゃ    りんご    バナナ

  • エクセルのドロップダウンリストの行の高さについて

    エクセル2007のドロップダウンリストの行の高さで、困っています。 「データの入力規制」で、現在は4行のドロップダウンを作っています。 検索でいろいろと調べると、ドロップダウンのリストの1行の高さは、親のセルと同じ高さに なっているようです。 自分の作った4行のドロップダウンは、4行で親のセルと同じ高さになってしまい、 非常に文字が小さくなっていて、読みにくく実用になりません。 エクセル2007のどこかの設定で、このように制限されているのでしょうか? 通常のように、ドロップダウンのリストの1行の高さを、親のセルと同じ高さにしたいので、 そのやり方を教えてください。

  • Excelの関数に詳しい方、お願いします。

    わかりづらい説明かもしれませんが、よろしくお願いします。 例として、 AAA*BBB*CCC*DDD*EEE*FFF AAA*BBB*CCC*DDD*EEE*FFF AAA*BBB*CCC*DDD*EEE*FFF AAA*BBB*CCC*DDD*EEE*FFF AAA*BBB*CCC*DDD*EEE*FFF ・ ・ ・ といった文字列がエクセルの先頭列A1&#65374;A100までずらりと並んでいるとします。 各アルファベットには任意の数字(日付など)が入るとして、この並んだ百件のデータからCCCの部分の最大値を表示するための適切な関数があれば教えていただけないでしょうか? 現在少々急いでいるため言葉足らずで申し訳ありませんが、よろしくお願いいたします.

  • ドロップダウンリストを大きくしたい。

    エクセル2000です。 入力規制でドロップダウンリストからの選択で入力しています。 リストデータが30件あったとして、ドロップダウンリスト内にその30件一度に表示させることはできないでしょうか?(10件程度しか表示されず、スクロールさせています) または、表示件数を増やすような設定は、ないでしょうか?