こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

以下のサイトを参考に別ブックからデータを参照する方法で苦戦しています。
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
どのように改変すれば良いのでしょうか?

投稿日時 - 2018-09-14 19:52:13

QNo.9537290

すぐに回答ほしいです

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

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

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

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


'以下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

投稿日時 - 2018-09-16 21:16:33

お礼

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

投稿日時 - 2018-09-20 19:09:33

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(6)

ANo.6

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

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

投稿日時 - 2018-09-16 21:29:24

ANo.4

こちらのテストではエラーなく動いています。
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

投稿日時 - 2018-09-16 15:43:56

お礼

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

投稿日時 - 2018-09-16 20:14:35

ANo.3

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

添付画像を例にすれば、
=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セルの入力規則の候補群フィールドに
動的に、候補群を埋め込む必要があるものと思います。
(少なくとも私はこの方法で実現しています。)

投稿日時 - 2018-09-16 12:28:18

補足

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

投稿日時 - 2018-09-16 19:58:45

お礼

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

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

投稿日時 - 2018-09-16 20:32:06

ANo.2

>同ブックの別シートでは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

投稿日時 - 2018-09-16 08:21:45

補足

ご指摘の通り、名前の定義は元ブックに作られていました。
が、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)

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

投稿日時 - 2018-09-16 12:13:48

ANo.1

なぜエラーが出たのか探ってみては
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

投稿日時 - 2018-09-15 16:11:34

補足

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

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

投稿日時 - 2018-09-15 18:22:34

お礼

試してみました。

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)で探せるのに、
別ブックにすると、なぜダメなのでしょうか?

投稿日時 - 2018-09-16 06:26:07

あなたにオススメの質問