入力規則のドロップダウンリストを連動

質問

以下のサイトを参考に別ブックからデータを参照する方法で苦戦しています。
http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vba_validation.html

Sub name_1()
　　Dim lCol As Long, lRow As Long
　　Dim i As Long, nName As String

Dim Wb As Workbook ←追記
Set Wb = Workbooks("MyBook.xls") ←追記

　　　　On Error Resume Next
　　　　With Wb.Sheets("Sheet2")
　　　　　　lCol = .Range("A1").End(xlToRight).Column
　　　　　　ActiveWorkbook.Names("項目リスト").Delete
　　　　　　ActiveWorkbook.Names.Add Name:="項目リスト", _
　　　　　　　　RefersTo:=.Range(.Cells(1, 1), .Cells(1, lCol))
　　　　　　'----名前の定義
　　　　　　For i = 1 To lCol
　　　　　　　　lRow = .Cells(1, i).End(xlDown).Row
　　　　　　　　nName = .Cells(1, i).Value
　　　　　　　　ActiveWorkbook.Names(nName).Delete
　　　　　　　　.Range(.Cells(1, i), .Cells(lRow, i)).CreateNames Top:=True
　　　　　　Next i
　　　　End With
End Sub

Sub Macro2()
　　name_1
　　With Range("A2:A10").Validation
　　　　'--入力規則を削除
　　　　.Delete
　　　　'--入力規則を設定
　　　　.Add Type:=xlValidateList, _
　　　　　　Formula1:="=項目リスト"
　　End With
　　'--B2セルへ入力規則を設定
　　With Range("B2:B10").Validation
　　　　.Delete
　　　　.Add Type:=xlValidateList, _
　　　　　　Formula1:="=IF(A2="""",A2,INDIRECT(A2))"
　　End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim c As Range

Dim Wb As Workbook ←追記
Set Wb = Workbooks("MyBook.xls") ←追記

　　　　If Not (Application.Intersect(Target, Range("A2:B10")) Is Nothing) Then
　　　　name_1
　　　　Application.EnableEvents = False
　　　　　　If Target.Column = 1 Then
　　　　　　　　If Target.Value = "" Then
　　　　　　　　　　Target.Offset(0, 1).Value = ""
　　　　　　　　Else
　　　　　　　　　　Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole) ←ここでエラー
　　　　　　　　　　If c Is Nothing Then
　　　　　　　　　　　　Target.Offset(0, 1).Value = ""
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If

　　　　　　If Target.Column = 2 Then
　　　　　　　　If Target.Value = "" Then
　　　　　　　　　　Target.Offset(0, -1).Value = ""
　　　　　　　　End If
　　　　　　End If
　　　　Application.EnableEvents = True
　　　　End If
End Sub
どのように改変すれば良いのでしょうか？

回答No.5

HohoPapa · ベストアンサー

>まさに、
> 入力規則を設定するブックが開くときに
> マクロで候補群の埋まったブックも開き
>必要なセル範囲の候補群たちを
>元ブック側に定義する
> という方法を取っています。

ありゃ、ごめんなさい。
既に解決しているようですが
私のコードを紹介させていただきます。

候補群を配列変数に保持するやり方です。
よかったら参考にしてください。

'以下ThisWorkbookモジュール
Private Sub Workbook_Open()
　GetMyList
End Sub

'以下、シートモジュール
Private Sub Worksheet_Change(ByVal Target As Range)
　SetMyList Target
End Sub

'以下、標準モジュール
'//-------------------------------------
'//　定数、変数
'//-------------------------------------
　Const Listbook = "C:\OKWave\コンボボックス制御\候補群.xlsx"
　Const MaxRows = 7　　 'メインの想定最大候補数
　Const Maxcols = 10　　'サブの想定最大候補数
　Const MCombRow = 2　　'メインの候補群セットセルの行位置
　Const MCombCol = 2　　'メインの候補群セットセルの列位置
　Const SCombRow = 2　　'サブの候補群セットセルの行位置
　Const SCombCol = 3　　'サブの候補群セットセルの列位置
　Dim MyLists(MaxRows, Maxcols) As String　'候補群格納変数

'//-------------------------------------
'//　候補群ブックから一覧を取得して、
'//　　二次配列に格納し、主コンボボックスに候補群をセット
'//-------------------------------------
Sub GetMyList()
　Dim wb As Workbook
　Dim RowCounter As Long
　Dim ColCounter As Long
　Dim wkList As String
　Dim tgRange As Range

　'候補群格納ブックが開いていたらいったん閉じる
　For Each wb In Workbooks
　　If wb.FullName = Listbook Then
　　　wb.Close
　　End If
　Next wb

　Set wb = Workbooks.Open(Listbook)
　Erase MyLists

　With wb.Sheets(1)
　　For RowCounter = 1 To MaxRows
　　　For ColCounter = 1 To Maxcols
　　　　MyLists(RowCounter - 1, ColCounter) = _
　　　　　.Cells(RowCounter, ColCounter).Value
　　　Next ColCounter
　　Next RowCounter
　End With

　ColCounter = 1
　wkList = ""
　Do
　　If MyLists(0, ColCounter) = "" Then Exit Do
　　wkList = wkList & MyLists(0, ColCounter) & ","
　　ColCounter = ColCounter + 1
　Loop
　If wkList = "" Then Exit Sub
　wkList = Left(wkList, Len(wkList) - 1)

　With ThisWorkbook.Sheets(1)
　　Set tgRange = .Cells(MCombRow, MCombCol)
　End With
　ChgValidation tgRange, wkList

　wb.Close

End Sub

'//-------------------------------------
'//　副コンボボックスに候補群をセット
'//-------------------------------------
Sub SetMyList(ByVal Target As Range)

　Dim ColCounter As Long
　Dim RowCounter As Long
　Dim ColNum As Long
　Dim wkList As String
　Dim tgRange As Range

　If ((Target.Row <> MCombRow) Or (Target.Column <> MCombCol)) Then Exit Sub
　With ThisWorkbook.Sheets(1)
　　.Cells(SCombRow, SCombCol).Value = ""
　End With
　ColNum = 0

　For ColCounter = 1 To Maxcols
　　If Target.Value = MyLists(0, ColCounter) Then
　　　ColNum = ColCounter
　　　Exit For
　　End If
　Next ColCounter

　RowCounter = 1
　wkList = ""
　Do
　　If MyLists(RowCounter, ColNum) = "" Then Exit Do
　　wkList = wkList & MyLists(RowCounter, ColNum) & ","
　　RowCounter = RowCounter + 1
　Loop
　If wkList = "" Then Exit Sub
　wkList = Left(wkList, Len(wkList) - 1)

　With ThisWorkbook.Sheets(1)
　　Set tgRange = .Cells(SCombRow, SCombCol)
　End With

　ChgValidation tgRange, wkList

End Sub

'//-------------------------------------
'//　入力規則の設定、候補群セット関数
'//-------------------------------------
Sub ChgValidation(MyRange As Range, SelText As String)

　With MyRange
　　.Validation.Delete
　　.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
　　　 xlBetween, Formula1:=SelText
　　.Validation.IgnoreBlank = True
　　.Validation.InCellDropdown = True
　　.Validation.InputTitle = ""
　　.Validation.ErrorTitle = ""
　　.Validation.InputMessage = ""
　　.Validation.ErrorMessage = ""
　　.Validation.IMEMode = xlIMEModeNoControl
　　.Validation.ShowInput = True
　　.Validation.ShowError = True
　End With

End Sub

お礼

新たな方法をご提示頂き、有難うございました。

回答No.6

HohoPapa

さきほどポストした補足です。
画像を添付漏れしたので上げます。

また、範囲名を使っているのではなく
候補群の値を直接、入力候補群設定フィールドに
埋めています。

回答No.4

watabe007

こちらのテストではエラーなく動いています。
Sub Macro2()の内容は見ていませんので
Sub name_1()
　　Dim lCol As Long, lRow As Long
　　Dim i As Long, nName As String
　　Dim Wb As Workbook
　　Set Wb = Workbooks("MyBook.xls")
　　On Error Resume Next
　　With Wb.Sheets("Sheet2")
　　　　lCol = .Range("A1").End(xlToRight).Column
　　　　Wb.Names("項目リスト").Delete
　　　　Wb.Names.Add Name:="項目リスト", _
　　　　　　RefersTo:=.Range(.Cells(1, 1), .Cells(1, lCol))
　　　　'----名前の定義
　　　　For i = 1 To lCol
　　　　　　lRow = .Cells(1, i).End(xlDown).Row
　　　　　　nName = .Cells(1, i).Value
　　　　　　Wb.Names(nName).Delete
　　　　　　.Range(.Cells(1, i), .Cells(lRow, i)). _
　　　　　　　　CreateNames Top:=True
　　　　Next i
　　End With
End Sub
'↓ If c Is Nothing Then の場合の処理だけで、見つかった場合は処理は無し？
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim c As Range
　　Dim Wb As Workbook
　　Set Wb = Workbooks("MyBook.xls")
　　If Not (Application.Intersect(Target, Range("A2:B10")) Is Nothing) Then
　　　　name_1
　　　　Application.EnableEvents = False
　　　　If Target.Column = 1 Then
　　　　　　If Target.Value = "" Then
　　　　　　　　Target.Offset(0, 1).Value = ""
　　　　　　Else
　　　　　　　　Set c = Wb.Sheets("Sheet2").Range(Target.Value). _
　　　　　　　　　　Find(Target.Offset(0, 1).Value, lookat:=xlWhole)
　　　　　　　　If c Is Nothing Then
　　　　　　　　　　'Target.Offset(0, 1).Valueが見つからなければ
　　　　　　　　　　Target.Offset(0, 1).Value = ""
　　　　　　　　Else
　　　　　　　　　　'↑見つからなかった時の処理だけで見つかった時は？
　　　　　　　　　　MsgBox c.Address(External:=True) & " にミッケ"
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　　　If Target.Column = 2 Then
　　　　　　If Target.Value = "" Then
　　　　　　　　Target.Offset(0, -1).Value = ""
　　　　　　End If
　　　　End If
　　　　Application.EnableEvents = True
　　End If
End Sub

お礼

ご教示頂いたコードで確かにエラーにはなりませんでしたが、
肝心のSub Macro2()が利用できずに、
当方の求めている動作にはなりませんでした。

回答No.3

HohoPapa

>別ブックからデータを参照する方法
やりたいことの要は、

添付画像を例にすれば、
=IF(A2="",A2,INDIRECT(A2))
なかでも、
INDIRECT(A2)
この記述で、"果物"という名前を持つ範囲名のセル群を
自ブックではなく、同時に開いている別なブックから探してくれるか？

ということと思います。

詳しく確認したことはありませんが、
複数のブックが開いている可能性もありますので、
エクセルは、そこまでは賢くないだろうと思います。
少なくとも私が行ってみる限り探してくれません。

また、
=IF(A2="",A2,INDIRECT(A2))
を
=IF(A2="",A2,INDIRECT([候補群.xlsx]Sheet1!$B$2:$B$6))
と書き換えることも許してくれません

つまり、セルの入力規則に使う候補群を
別なブックのセル範囲から得たいのであれば、
http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vba_validation.html
この延長上では実現するのは、非常に厳しと思います。

やるとすれば、例えば、
入力規則を設定するブックが開くときに
マクロで候補群の埋まったブックも開き
必要なセル範囲の候補群たちを自シートに複写するとか

配列変数に格納しながら、A2セルの候補群を埋め
その後、Worksheet_Changeのイベントを使い、
B2セルの入力規則の候補群フィールドに
動的に、候補群を埋め込む必要があるものと思います。
（少なくとも私はこの方法で実現しています。）

お礼

Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole)

を
With Wb.Sheets("リスト")
lCol = .Cells.Find(Target).Column
Set c = .Columns(lCol).Find(Target.Offset(0, 1).Value, lookat:=xlWhole)
End With

に改変することで思い通りの動作が確認できましたが、不安です。

補足

まさに、
入力規則を設定するブックが開くときに
マクロで候補群の埋まったブックも開き
必要なセル範囲の候補群たちを
元ブック側に定義する
という方法を取っています。

回答No.2

watabe007

>同ブックの別シートではRange(Target.Value)で探せるのに・・・
Workbooks("MyBook.xls")に正しく範囲名が設定されているのか確認した方が
よいです。
>ActiveWorkbook.Names("項目リスト").Delete
>ActiveWorkbook.Names.Add Name:="項目リスト", _
この場合、MyBook.xlsは、アクティブにはなっていないでしょう
Wb.Names("項目リスト").Delete
Wb.Names.Add Name:="項目リスト",

Sub name_1()
　　Dim lCol As Long, lRow As Long
　　Dim i As Long, nName As String
　　Dim Wb As Workbook

　　Set Wb = Workbooks("MyBook.xls")
　　On Error Resume Next
　　With Wb.Sheets("Sheet2")
　　　　lCol = .Range("A1").End(xlToRight).Column
　　　　Wb.Names("項目リスト").Delete
　　　　Wb.Names.Add Name:="項目リスト", _
　　　　　　RefersTo:=.Range(.Cells(1, 1), .Cells(1, lCol))
　　　　'----名前の定義
　　　　For i = 1 To lCol
　　　　　　lRow = .Cells(1, i).End(xlDown).Row
　　　　　　nName = .Cells(1, i).Value
　　　　　　Wb.Names(nName).Delete
　　　　　　.Range(.Cells(1, i), .Cells(lRow, i)).CreateNames Top:=True
　　　　Next i
　　End With
End Sub

補足

ご指摘の通り、名前の定義は元ブックに作られていました。
が、MyBook.xlsに定義を作ると入力規則で名前の指定が出来なくなってしまいます（外部指定が出来ない）。

なので、以下のように書き換えました。

Sub name_1()
Dim lCol As Long, lRow As Long
Dim i As Long, nName As String

Dim Wb As Workbook
Set Wb = Workbooks("Book2.xlsx")

On Error Resume Next
With Wb.Sheets("リスト")
lCol = .Range("A1").End(xlToRight).Column
ActiveWorkbook.Names("項目リスト").Delete
ActiveWorkbook.Names.Add Name:="項目リスト", _
RefersTo:=.Range(.Cells(1, 1), .Cells(1, lCol))

For i = 1 To lCol
lRow = .Cells(1, i).End(xlDown).Row
nName = .Cells(1, i).Value
ActiveWorkbook.Names(nName).Delete
ActiveWorkbook.Names.Add Name:=nName, _
RefersTo:=.Range(.Cells(2, i), .Cells(lRow, i))
Next i
End With
End Sub

この場合の

Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole)

は、どのように書き換えるのでしょうか？

回答No.1

watabe007

なぜエラーが出たのか探ってみては
Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole) ←ここでエラー
　　　↓
On Error Resume Next
Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole)
If Err Then
MsgBox Wb.Name & "のSheet2の範囲名：" & Target.Value & " から" & vbCrLf & _
Target.Offset(0, 1).Value & " を探していますが間違いないですか？"
Application.EnableEvents = True
Exit Sub
End If
On Error GoTo 0

お礼

試してみました。

Wb.Name＝sheet2
Target.Value＝項目2
Target.Offset(0, 1).Value＝2-1

と、間違いなく、こちらの意図している文字列を探しに行っているように見えたのですが、どうやらRange(Target.Value)がダメなようです。

Targetが項目1ならA列から、
Targetが項目2ならB列から、
一致する文字列を探したいです。

同ブックの別シートではRange(Target.Value)で探せるのに、
別ブックにすると、なぜダメなのでしょうか？

補足

ご教示有難うございます。
確認できる環境に居ないので、週明けに試してみます。

ちなみに、エラー内容は『アプリケーション定義またはオブジェクト定義のエラー』です。