【謎エラー解消したい】Excelテーブルの多段入力規則リストをSQLで動的にセットする

https://qiita.com/taleau/items/dff9b94bcca62c3f4aa6

多段プルダウンネタによく出てくる`INDIRECT`やスピルを使った計算エリアを使っていると、製品仕様が入り組んでいるため次第に盛大な`INDIRECT`祭りになって**テーブルや名前付きセルが氾濫**してきたのと、**フォーム側のテーブルの列の並びを変更すると入力規則が壊れる**という事故が発生・・・

そこで最近Access学習の中で出会ったSQLで入力規則リストを動的に出させる方法にトライ。

**テーブル内のセルを選択した時、その行の他のテーブル内容で入力規則リストを都度設定していく**形を取りました。

![SQL_D_Songs3.gif](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/db7eaf27-b63d-a794-2c98-988fd1fffd8b.gif)

整備しやすいし使用感は前と変わらないし良いじゃん！
と思っていたら職場で謎のエラーが・・・

タスケテ・・・

## 謎の課題（エラー）
### 実行時エラー '-2147467259 (80004005)' インストール可能なISAMドライバーが見つかりませんでした
どうやったら再現するのかわからないけど1度出た謎のエラー

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/ba0a58c0-54a8-e64e-e58b-eeee22d8f3a8.png)

### ブックを閉じると保存できてなくて同名ブックが「編集できるようになりました」というポップアップと共に立ち上がる
これも再現方法わからずでしばらく発生してないのでスクショが撮れていないのですが、保存できないのは致命的なので誰か助けて・・・


ここから本題。コピペで再現環境作れるようにはなってるはずです。

## Excelシート
### フォーム
#### F_Song

テーブル内のセルを選択した時、
その行の他のテーブル内容で入力規則リストが絞られていきます。

|ディスク名|作詞|作曲|編曲|楽曲名|
|---|---|---|---|---|
||||||
||||||
||||||
||||||
||||||

本当は注文書フォーム的なものが良いなと思ったけど、プログラミングとは別の趣味を挟んだ全く別物を当て込んでみました。

**DIALOGUE+** という声優アーティストユニットの楽曲をマスターデータとして作ってみました。
楽曲から入ったクチですが、メンバーもスタッフも大好きなグループなのでここから入りましたという稀有な未来のログっ子（DIALOGUE+ファンの意）もお待ちしております。

https://dialogue-music.jp/discography/

https://ja.wikipedia.org/wiki/DIALOGUE%2B#%E3%83%87%E3%82%A3%E3%82%B9%E3%82%B3%E3%82%B0%E3%83%A9%E3%83%95%E3%82%A3


### マスターデータ
#### MT_Songs

[ディスク名]列は
`=VLOOKUP([@ディスクID],MT_Disc,3,FALSE)`
を入れます。
（サブクエリでやると面倒だったのでVLOOKUPでMT_Songs１つにまとめてます。。。）

|ID|ディスクID|ディスク名|楽曲名|作詞|作曲|編曲|
|---|---|---|---|---|---|---|
|1|1|はじめてのかくめい!|はじめてのかくめい!|田淵智也|田淵智也|田中秀和|
|2|1|はじめてのかくめい!|ダイアローグ+インビテーション!|ZAQ|ZAQ|堀江晶太|
|3|4|DREAMY-LOGUE|大冒険をよろしく|田淵智也|田淵智也|堀江晶太|
|4|4|DREAMY-LOGUE|好きだよ、好き。|田淵智也|田淵智也|佐藤純一|
|5|4|DREAMY-LOGUE|トーク！トーク！トーク！|大胡田なつき|田淵智也|中山真斗|
|6|4|DREAMY-LOGUE|Domestic Force!!|津野米咲|田淵智也|eba|
|7|4|DREAMY-LOGUE|パジャマdeパーティー|三森すずこ|田淵智也|園田健太郎|
|8|4|DREAMY-LOGUE|ぼくらは素敵だ|田淵智也|田淵智也|広川恵一|
|9|13|ぼくかくオンライン|かいかいせんげん！|田淵智也|田淵智也|田淵智也|
|10|13|ぼくかくオンライン|DIALOGUE＋は上々だ|田淵智也|大畑拓也|栁舘周平,大畑拓也|
|11|13|ぼくかくオンライン|DIALOGUE＋はまた立ち上がる|田淵智也|田淵智也,栁舘周平|栁舘周平|
|12|2|あたりまえだから|あたりまえだから|田淵智也|田淵智也|広川恵一|
|13|3|夏の花火と君と青|夏の花火と君と青|本間翔太,田淵智也|瀬名航|瀬名航,伊藤翼|
|14|5|人生イージー?|人生イージー?|田淵智也|田淵智也|田中秀和|
|15|5|人生イージー?|走れ|佐々木亮介,田淵智也|ZAQ|eba|
|16|6|あやふわアスタリスク|あやふわアスタリスク|田淵智也|田淵智也|広川恵一|
|17|6|あやふわアスタリスク|花咲く僕らのアンサーを|瀬名航|瀬名航|中山真斗|
|18|7|おもいでしりとり|おもいでしりとり|田淵智也|田淵智也|睦月周平|
|19|7|おもいでしりとり|シュガーロケット|古屋真|広川恵一|和田たけあき|
|20|8|DIALOGUE+1|Sincere Grace|田淵智也|田淵智也|eba|
|21|8|DIALOGUE+1|ドラマティックピース‼︎|田淵智也|田淵智也|フジファブリック|
|22|8|DIALOGUE+1|謎解きはキスのあとで|サティフォ|ONIGAWARA|ONIGAWARA,伊藤翼|
|23|8|DIALOGUE+1|プライベイト|大胡田なつき|睦月周平|睦月周平|
|24|8|DIALOGUE+1|I my me mind|大胡田なつき|広川恵一,田淵智也|広川恵一|
|25|8|DIALOGUE+1|アイガッテ♡ランテ|田淵智也|田中秀和|田中秀和|
|26|8|DIALOGUE+1|20xxMUEの光|やしきん|田淵智也|やしきん|
|27|8|DIALOGUE+1|透明できれい|田淵智也|瀬名航|伊藤翼|
|28|8|DIALOGUE+1|はじめてのかくめい!2021|田淵智也|田淵智也|田中秀和|
|29|9|はっちゃけダイアローグ＋クリスマス！|はっちゃけダイアローグ＋クリスマス！|田淵智也|佐高陵平|佐高陵平|
|30|10|僕らが愚かだなんて誰が言った|僕らが愚かだなんて誰が言った|田淵智也|田淵智也|kz(livetune)|
|31|10|僕らが愚かだなんて誰が言った|パンケーキいいな|大胡田なつき|Akki|Akki|
|32|11|恋は世界定理と共に|恋は世界定理と共に|田淵智也|サティフォ|中山真斗|
|33|11|恋は世界定理と共に|ガガピーガガ|不明|不明|不明|
|34|12|デネブとスピカ|デネブとスピカ|不明|不明|不明|


#### MT_Disc

リリース日は今回は使ってませんがサブクエリで日付比較の練習しても良いかもですね。

|ID|ディスクID|ディスク名|リリース日|
|---|---|---|---|
|1|1stシングル|はじめてのかくめい!|2019/10/23|
|2|1st限定シングル|あたりまえだから|2020/6/17|
|3|2nd限定シングル|夏の花火と君と青|2020/12/23|
|4|1stミニアルバム|DREAMY-LOGUE|2021/2/3|
|5|2ndシングル|人生イージー?|2021/2/3|
|6|3rdシングル|あやふわアスタリスク|2021/2/3|
|7|4thシングル|おもいでしりとり|2021/5/19|
|8|1stフルアルバム|DIALOGUE+1|2021/9/1|
|9|3rd限定シングル|はっちゃけダイアローグ＋クリスマス！|2021/12/15|
|10|5thシングル|僕らが愚かだなんて誰が言った|2022/4/13|
|11|6thシングル|恋は世界定理と共に|2022/6/15|
|12|7thシングル|デネブとスピカ|2022/8/24|
|13|ぼくかくオンライン|ぼくかくオンライン|-|


## コード側

### 標準モジュール：SQL部分

メイン部分。
`SELECT`文の`FROM`句に入れるDBを`[シート名$A2:G30]` という形式で入れないいけないので少し小細工が必要。

あとは普通にSELECT文をガシガシ書くだけ。
フォームのフィールド要素が入るとその行の他のフィールドの選択肢が絞られています。

SQLはワイルドカードが`*`ではなく`%`なので`LIKE`演算子を使う場合は注意。

``` vb
Option Explicit

' MasterTable
Public Const MT_Songs = "MT_Songs"
Public Const MT_Disc = "MT_Disc"

' Form
Public Const F_Song = "F_Song"

Function AddValidation_SQL_楽曲名(ByVal Target As Range, _
                                          clsF As clsFormLO, _
                                         clsDB As clsADODB) As Boolean
  With clsDB
    .DBaddrs = GetDBAddress(MT_Songs)
    
    .strSQL = "SELECT  楽曲名 FROM [" & .DBaddrs & "] "
    .strSQL = .strSQL & " WHERE ディスク名 LIKE '%" & clsF.ディスク名 & "%' "
    .strSQL = .strSQL & " AND 作詞 LIKE '%" & clsF.作詞 & "%' "
    .strSQL = .strSQL & " AND 作曲 LIKE '%" & clsF.作曲 & "%' "
    .strSQL = .strSQL & " AND 編曲 LIKE '%" & clsF.編曲 & "%' "
    .strSQL = .strSQL & " ORDER BY ID"
    
    Call .レコードセットを開く
    Call .リスト用のカテゴリーを取得("楽曲名")

  End With
  
  AddValidation_SQL_楽曲名 = True
    
End Function
Function AddValidation_SQL_作詞(ByVal Target As Range, _
                                        clsF As clsFormLO, _
                                       clsDB As clsADODB) As Boolean
  With clsDB
    .DBaddrs = GetDBAddress(MT_Songs)
    
    .strSQL = "SELECT DISTINCT 作詞 FROM [" & .DBaddrs & "] "
    .strSQL = .strSQL & " WHERE ディスク名 LIKE '%" & clsF.ディスク名 & "%' "
    .strSQL = .strSQL & " AND 作詞 LIKE '%" & clsF.作詞 & "%' "
    .strSQL = .strSQL & " AND 作曲 LIKE '%" & clsF.作曲 & "%' "
    .strSQL = .strSQL & " AND 編曲 LIKE '%" & clsF.編曲 & "%' "
    .strSQL = .strSQL & " AND 楽曲名 LIKE '%" & clsF.楽曲名 & "%' "
    
    Call .レコードセットを開く
    Call .リスト用のカテゴリーを取得("作詞")

  End With
  
  AddValidation_SQL_作詞 = True
    
End Function
Function AddValidation_SQL_作曲(ByVal Target As Range, _
                                        clsF As clsFormLO, _
                                       clsDB As clsADODB) As Boolean
  With clsDB
    .DBaddrs = GetDBAddress(MT_Songs)
    
    .strSQL = "SELECT DISTINCT 作曲 FROM [" & .DBaddrs & "] "
    .strSQL = .strSQL & " WHERE ディスク名 LIKE '%" & clsF.ディスク名 & "%' "
    .strSQL = .strSQL & " AND 作詞 LIKE '%" & clsF.作詞 & "%' "
    .strSQL = .strSQL & " AND 作曲 LIKE '%" & clsF.作曲 & "%' "
    .strSQL = .strSQL & " AND 編曲 LIKE '%" & clsF.編曲 & "%' "
    .strSQL = .strSQL & " AND 楽曲名 LIKE '%" & clsF.楽曲名 & "%' "
    
    Call .レコードセットを開く
    Call .リスト用のカテゴリーを取得("作曲")

  End With
  
  AddValidation_SQL_作曲 = True
    
End Function
Function AddValidation_SQL_編曲(ByVal Target As Range, _
                                        clsF As clsFormLO, _
                                       clsDB As clsADODB) As Boolean
  With clsDB
    .DBaddrs = GetDBAddress(MT_Songs)
    
    .strSQL = "SELECT DISTINCT 編曲 FROM [" & .DBaddrs & "] "
    .strSQL = .strSQL & " WHERE ディスク名 LIKE '%" & clsF.ディスク名 & "%' "
    .strSQL = .strSQL & " AND 作詞 LIKE '%" & clsF.作詞 & "%' "
    .strSQL = .strSQL & " AND 作曲 LIKE '%" & clsF.作曲 & "%' "
    .strSQL = .strSQL & " AND 編曲 LIKE '%" & clsF.編曲 & "%' "
    .strSQL = .strSQL & " AND 楽曲名 LIKE '%" & clsF.楽曲名 & "%' "
    
    Call .レコードセットを開く
    Call .リスト用のカテゴリーを取得("編曲")

  End With
  
  AddValidation_SQL_編曲 = True
    
End Function

Function AddValidation_SQL_ディスク名(ByVal Target As Range, _
                                              clsF As clsFormLO, _
                                             clsDB As clsADODB) As Boolean
                                                           
  With clsDB
    .DBaddrs = GetDBAddress(MT_Songs)
    
    .strSQL = "SELECT DISTINCT ディスク名 FROM [" & .DBaddrs & "] "
    .strSQL = .strSQL & " WHERE 作詞 LIKE '%" & clsF.作詞 & "%' "
    .strSQL = .strSQL & " AND 作曲 LIKE '%" & clsF.作曲 & "%' "
    .strSQL = .strSQL & " AND 編曲 LIKE '%" & clsF.編曲 & "%' "
    .strSQL = .strSQL & " AND 楽曲名 LIKE '%" & clsF.楽曲名 & "%' "
    
    Call .レコードセットを開く
    Call .リスト用のカテゴリーを取得("ディスク名")
  End With
  AddValidation_SQL_ディスク名 = True
    
End Function

Function GetDBAddress(ListObjName As String)

  Dim wsName As String
  wsName = Range(ListObjName).Parent.Name
  
  Dim AreaAddress As String
  AreaAddress = Range(ListObjName).ListObject.Range.Address(False, False)
  
  ' [シート名$A2:G30] という形式で返す
  GetDBAddress = wsName & "$" & AreaAddress
  
End Function

```

### Class ADODB

全ておまじない部分。
ググった結果をクラスにまとめただけ。

参照設定だけ別途必要です。

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/36dd96d0-e6ca-4364-bc0d-8e93c7597097.png)


``` vb:clsADODB
Option Explicit

Public adoCON As New ADODB.Connection
Public adoRS As New ADODB.Recordset
Public strSQL As String
Public odbdDB As Variant
Public strCat As String
Public DBaddrs As String
 
Private Sub Class_Initialize()

  odbdDB = ThisWorkbook.FullName
  Set adoCON = New ADODB.Connection
  
  With adoCON
   .Provider = "Microsoft.ACE.OLEDB.12.0"
   .ConnectionString = "Data Source = " & odbdDB & _
   ";Extended Properties =Excel 12.0;"
   .Open
  End With
  
  adoRS.CursorLocation = adUseClient

End Sub

Private Sub Class_Terminate()

 Set adoCON = Nothing
 Set adoRS = Nothing

End Sub

Public Sub レコードセットを開く()

On Error GoTo Err:
 adoRS.Open strSQL, adoCON, adOpenStatic ', adLockReadOnly
 Exit Sub
 
Err:
Select Case Err.Number
  Case -2147217900:
    MsgBox "未入力の列があります。"
    End
  Case Else:
    MsgBox "エラーNo：" & Err.Number & vbLf & Err.Description
    End
  End Select

End Sub

Public Sub レコードセットを閉じる()

 adoRS.Close

End Sub

Public Sub 入力規則リストをセットする(Target As Range, Is規則外入力を許可 As Boolean)

  Dim aStyle
  If Is規則外入力を許可 Then
    aStyle = xlValidAlertWarning
  Else
    aStyle = xlValidAlertStop
  End If

 With Target.Validation
  .Delete
  If strCat <> "" Then
   .Add _
   Type:=xlValidateList, _
   AlertStyle:=aStyle, _
   Formula1:=strCat
  End If
 End With

End Sub


Public Sub リスト用のカテゴリーを取得(fldName As String)

  Dim rc As Long: rc = adoRS.RecordCount
  
  If rc = 0 Then: Exit Sub
  
  Dim Arr
  ReDim Arr(rc - 1)
  Dim I: I = 0
  Do Until adoRS.EOF
      Arr(I) = adoRS(fldName)
      If IsNull(Arr(I)) Then: Arr(I) = "" 'Nullなら空文字で置換する
      I = I + 1
    adoRS.MoveNext
  Loop
  
  strCat = Join(Arr, ",")
  
  Call レコードセットを閉じる
  
End Sub

```

### Class フォームテーブル

フォームのテーブルのフィールド名をガシガシ突っ込んでいくだけのほぼ単純作業ゾーンです。

|ディスク名|作詞|作曲|編曲|楽曲名|
|---|---|---|---|---|
||||||

``` vb:clsFormLO
Option Explicit

Public LO As ListObject

Public ディスク名 As String
Public 楽曲 As String
Public 作詞 As String
Public 作曲 As String
Public 編曲 As String
Public 楽曲名 As String

Dim R1st As Long
Dim RLast As Long
Dim C1st As Long
Dim CLast As Long

Private Sub Class_Initialize()

  Set LO = Range(F_Song).ListObject

End Sub

Private Sub Class_Terminate()

  Set LO = Nothing

End Sub

Public Sub Activeレコードの他のアイテムを取得()

  On Error Resume Next '空セルによる型エラー対策
  
    ディスク名 = Activeレコードの指定フィールドのアイテム("ディスク名")
    楽曲 = Activeレコードの指定フィールドのアイテム("楽曲")
    作詞 = Activeレコードの指定フィールドのアイテム("作詞")
    作曲 = Activeレコードの指定フィールドのアイテム("作曲")
    編曲 = Activeレコードの指定フィールドのアイテム("編曲")
    楽曲名 = Activeレコードの指定フィールドのアイテム("楽曲名")
  
  On Error GoTo 0
  
End Sub

Public Function Activeレコードの指定フィールドのアイテム(fldName As String)
  
  Dim clm As Range
  Set clm = LO.ListColumns(fldName).DataBodyRange
  
  Dim idxCur As Long  '行インデックス
  idxCur = ActiveCell.Row - LO.DataBodyRange(1).Row + 1
  
  Activeレコードの指定フィールドのアイテム = clm(idxCur, 1).Value

End Function

Public Function GetActiveフィールド名() As String

  Call SetDataBodyRange
  Call ActiveCellがテーブル範囲外なら全処理を中止

  Dim idxLC As Long  '列インデックス
  idxLC = ActiveCell.Column - C1st + 1
  GetActiveフィールド名 = LO.ListColumns(idxLC).Name

End Function

Private Sub SetDataBodyRange()

  R1st = LO.DataBodyRange(1).Row
  C1st = LO.DataBodyRange(1).Column
  RLast = R1st + LO.ListRows.Count - 1
  CLast = C1st + LO.ListColumns.Count - 1

End Sub

Private Sub ActiveCellがテーブル範囲外なら全処理を中止()
  
  If ActiveCell.Row < R1st Or ActiveCell.Row > RLast Then: End
  If ActiveCell.Column < C1st Or ActiveCell.Column > CLast Then: End

End Sub

```




### シートモジュール（フォームテーブルがあるシート）

テーブル内のセルを選択した時のその行の他のテーブル内容で入力規則リストを都度設定していくイベントパート

ActiveCellがテーブル範囲内か否かは`clsF.GetActiveフィールド名`の中で判断して否なら`End`処理してます。

ここもフォームのフィールド名を`Case`内と`Call`先にガシガシ書くだけ。

``` vb
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  Dim clsF As New clsFormLO
  Call clsF.Activeレコードの他のアイテムを取得
  Dim clsDB As New clsADODB

  Dim Is入力規則を変更する As Boolean: Is入力規則を変更する = False
  
  Select Case clsF.GetActiveフィールド名
    Case Is = "楽曲名": Is入力規則を変更する = AddValidation_SQL_楽曲名(Target, clsF, clsDB)
    Case Is = "作詞": Is入力規則を変更する = AddValidation_SQL_作詞(Target, clsF, clsDB)
    Case Is = "作曲": Is入力規則を変更する = AddValidation_SQL_作曲(Target, clsF, clsDB)
    Case Is = "編曲": Is入力規則を変更する = AddValidation_SQL_編曲(Target, clsF, clsDB)
    Case Is = "ディスク名": Is入力規則を変更する = AddValidation_SQL_ディスク名(Target, clsF, clsDB)
  End Select
  
  If Is入力規則を変更する = True Then: Call clsDB.入力規則リストをセットする(Target, True)

  Set clsDB = Nothing
  Set clsF = Nothing
  
End Sub

```

以上です。

AccessやPowerAppsでやる方が素直なのはわかっているのですが、
普通に行のコピペやCtrl+Dその他ショートカットなどExcelがGUIとして優秀なのと、新しいものにアレルギー反応を示す方もいる中での改善なので冒頭２つの謎課題をクリアしたい。

ご意見いただけると助かります。。。

## 参考サイト
### Access データベースにリンク？新しいバージョン？
ブック内で閉じてるし自分のPCだけで発生しているのでこれは違う？

https://support.microsoft.com/ja-jp/topic/excel-%E3%81%A7%E3%83%87%E3%83%BC%E3%82%BF%E3%83%86%E3%83%BC%E3%83%96%E3%83%AB%E3%82%92%E6%9B%B4%E6%96%B0%E3%81%99%E3%82%8B%E3%81%A8-%E3%82%A4%E3%83%B3%E3%82%B9%E3%83%88%E3%83%BC%E3%83%AB%E5%8F%AF%E8%83%BD%E3%81%AA-isam-%E3%83%89%E3%83%A9%E3%82%A4%E3%83%90%E3%83%BC%E3%81%8C%E8%A6%8B%E3%81%A4%E3%81%8B%E3%82%8A%E3%81%BE%E3%81%9B%E3%82%93%E3%81%A7%E3%81%97%E3%81%9F-%E3%81%A8%E3%81%84%E3%81%86%E3%82%A8%E3%83%A9%E3%83%BC%E3%81%8C%E8%A1%A8%E7%A4%BA%E3%81%95%E3%82%8C%E3%82%8B-f9753fad-d2ae-1776-336b-feedd46ca4e2

### 接続文字列内でスペルミス？
これはまた職場のもので見てみよう・・・

https://qiita.com/Econoshift/items/3019bab8b100ae469fee