More than 3 years have passed since last update.

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

Last updated at 2022-06-14Posted at 2022-06-13

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

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

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

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

タスケテ・・・

謎の課題（エラー）

実行時エラー '-2147467259 (80004005)' インストール可能なISAMドライバーが見つかりませんでした

どうやったら再現するのかわからないけど1度出た謎のエラー

ブックを閉じると保存できてなくて同名ブックが「編集できるようになりました」というポップアップと共に立ち上がる

これも再現方法わからずでしばらく発生してないのでスクショが撮れていないのですが、保存できないのは致命的なので誰か助けて・・・

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

Excelシート

フォーム

F_Song

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

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

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

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

マスターデータ

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演算子を使う場合は注意。

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

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

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

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 フォームテーブル

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

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

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先にガシガシ書くだけ。

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だけで発生しているのでこれは違う？

接続文字列内でスペルミス？

これはまた職場のもので見てみよう・・・

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up