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をどのように設定したらよいのか教えて下さい。
宜しくお願いいたします。
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の知識がなく、自分で修正することができません。
補足頂けましたら幸いです。
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.3
- 回答日時:
こんばんは!
超ベタな方法ですが・・・
やり方だけを↓の画像で説明します。(画像が小さかったら拡大してください。)
画像の上側を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.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.5
- 回答日時:
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.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.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.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.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が見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) Excel ドロップダウンリスト(入力規則)に関してです データの入力規則で元データ79000行のド 3 2023/07/17 10:06
- Excel(エクセル) Excelにの以下の設定方法について教えてください! C列にデータ入力の設定をしています。(出、入を 3 2022/06/22 01:33
- Excel(エクセル) エクセルについて教えてください。 2 2023/06/14 11:11
- Excel(エクセル) Excelで質問です。 詳細(写真) ①黄色の部分を全てプルダウンを設定する。 ②リストはG列 ③リ 1 2023/06/16 21:54
- Visual Basic(VBA) C3とC4のセルに、Visual basicで実行した時入力した値をC3に表示させ、その後に、C3に 1 2023/07/14 09:43
- Excel(エクセル) ログインIDの一発入力? 5 2023/07/07 12:30
- Excel(エクセル) 範囲選択すると最後の一行で急に出てくる#が邪魔で困っています。 ExcelでVLOOKUPで引っ張っ 2 2022/08/31 10:03
- Excel(エクセル) 余計なお世話的な「入力規則」?対策は? 2 2023/01/14 12:39
- Excel(エクセル) データ入力規則リスト 空白を無視 3 2022/07/13 15:11
- ルーター・ネットワーク機器 echoshow8の音声をBluetoothを介してパソコンで出力するやり方を教えて下さい。 3 2023/04/03 17:09
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルでの作業計算方法について
-
Microsoft1Officeの互換ソフト...
-
【マクロ】その時、その時で変...
-
はがきについて。
-
【マクロ】読取専用のファイル...
-
エクセル初心者です 関数の入れ...
-
【関数】適切な文字数の数字を...
-
LOOKUP関数を使えばいいのでし...
-
【関数】先頭だけにある、半角...
-
Excel ピボットテーブルで日付...
-
Excelのpivotについて質問です
-
時間によってファイル名が変わ...
-
エクセル 白黒印刷で白線を印刷...
-
Aというブックの1というシート...
-
エクセル関数を教えてください
-
WPS OFFICEでの縦書きについて
-
Excelのチェックボックスの使い...
-
エクセルの条件付き書式につい...
-
エクセルのセルに同じ大きさの...
-
エクセルの関数について教えて...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel 2019 のピボットテーブル...
-
[関数得意な方]教えて下さい・...
-
Excelにてある膨大なデータを管...
-
[関数について]わかる方教えて...
-
Excel初心者です。 詳しい方、...
-
excelの不要な行の削除ができな...
-
エクセル関数に詳しい方教えて...
-
INDIRECTを使わず excelで複数...
-
[オートフィルタ]で抽出された...
-
エクセルの神よ、ご回答を! エ...
-
エクセル関数に詳しい方、教え...
-
各ページの1番上の表示について
-
Excelで写真のような表を作った...
-
エクセルで不等号記号(≠)が上に...
-
数学 Tan(θ)-1/Cos(θ)について...
-
Excel 2019 は、SPILL機能があ...
-
Excelで全角を半角にしたいので...
-
条件付き書式を教えてください
-
Excel フィルターを掛けた状態...
-
[オートフィルタ]の適用範囲の...
おすすめ情報