Excel VBA ドロップダウンリスト 連動について

Question

##使用ソフト・プログラミング言語
使用ソフト：Excel2016
使用言語：VBA

前提・実現したいこと

Excel VBA ファイル(.xlsx)から別ブック(.xlsx)を起動して、セルに入力規則としてドロップダウンリストを作成いたしました。

ドロップダウンリストにて選択できる値を連動させたいのですが、ドロップダウンリストのファイルは.xlsxで可能でしょうか？

発生している問題・エラーメッセージ

各行の４列目の値を上限として、０から上限値までの整数をドロップダウンリストにて選択できるようにしましたが、
ドロップダウンリストの選択値の合計が４列目の値を超過する場合があることが判明しました。
６列目にて選択した値が４列目と等しい場合は、８列目・１０列目を０とし、６列目にて選択した値が、４列目の値未満の場合は、６列目・８列目で選択できる値は、１２列目【＝４列目－６列目－８列目－１０列目という演算列です。】の値を上限としたいです。

該当のソースコード

　Option Explicit
  Dim Row, Col, RMax, CMax, Cnt, Max, i As Integer
  Public CellList() As Variant
  Dim ListStr, Exf As String
public sub List()
　Cnt = 0 'カウント用変数を宣言し、初期値を格納する
  Exf = Dir(Path & "Q*.xlsx") '対象ファイルを取得する
  Do While Exf <> "" '対象ファイルがなくなるまで繰り返す
    If Ename(Cnt) = Exf Then '取得したファイル名と編集するファイル名が一致した場合
      If Cnt < 7 And De(Cnt + 11) = True Then
        On Error Resume Next
          Workbooks.Open Path & Exf '当該ファイルを開く
          Worksheets(1).Select '左から１番目のシートを選択
          Col = 1: Row = 1: CMax = 1: RMax = 1 '行番号 ・ 列番号の初期値を設定する
          CMax = Cells(1, 1).End(xlToRight).Column '右端の列番号を変数に格納する
          RMax = Cells(1, 1).End(xlDown).Row '下端の行番号を変数に格納する
          
          For Row = 2 To RMax '明細行の間繰り返す
            Max = Cells(Row, 4).Value '入庫数量を変数に格納する
            If Max > 40 Then '入庫数量が４０超えの場合
              Max = 40 '最大値を４０とする
            End If
            
            ReDim CellList(Max) '入力規則用配列を設定する
            For i = 0 To Max '入庫数量の間繰り返す
            CellList(i) = i '現在のカウント数値を配列に格納する
            Next
            ListStr = Join(CellList, ",") '入力リストを文字列化する
            For Col = 6 To 10 Step 2
              Cells(Row, Col).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=ListStr '入力規則を設定する
              Cells(Row, Col).Validation.ErrorTitle = "エラー" 'エラー発生時のタイトルを設定する
              Cells(Row, Col).Validation.ErrorMessage = "入荷数量以内で入力してください。" 'エラーメッセージを設定する
            Next
          Next
          
          Cells(1, 1).Select: ActiveWorkbook.Save 'A1セルに移動してここまでの作業を保存する
          Workbooks(Exf).Close 'Excelを終了する
        On Error GoTo 0
        
      End If
    End If
    Exf = Dir(): Cnt = Cnt + 1
  Loop
end sub

###入力ファイル
入力ファイルにつきましては、配達数量の入力処理を実施する端末がマクロ非対応のため、Xlsx拡張子とさせていただいています。
######配達数量を入力する前の状態の例です。

日付	届け先	商品名	入荷数量	配達数量１	配達数量２	配達数量３	残り
2020/02/01	A部B課	手提げ袋小	10	0	0	0	10
2020/02/01	C部D係	手提げ袋中	40	0	0	0	40

######配達数量１で入荷数量（最大値）を入力した場合

日付	届け先	商品名	入荷数量	配達数量１	配達数量２	配達数量３	残り
2020/02/01	A部B課	手提げ袋小	10	10	0	0	0
2020/02/01	C部D係	手提げ袋中	40	40	0	0	0

配達数量２も３も１以上の値が入力できるようになっています。

######配達数量１と２のそれぞれに入荷数量（最大値）を入力した場合

日付	届け先	商品名	入荷数量	配達数量１	配達数量２	配達数量３	残り
2020/02/01	A部B課	手提げ袋小	10	10	10	0	-10
2020/02/01	C部D係	手提げ袋中	40	40	40	0	-40

配達数量の合計が入荷数量を超過しているため、残り数量がマイナスとなっています。

Comments

[meg_]

"使用ソフト：Access2016"とありますがExcelの話ではないのですか？

[Yoshikun_0945]

Excelです。失礼しました。

[meg_]

文章を読みましたが理解できませんでした。シートとドロップダウンリストの画像を貼った方が分かりやすくなるかと思います。

Answer 1

xlsmブックのThisWorkbookモジュールに下記コードを記述します。

Option Explicit

Private WithEvents XlA As Excel.Application

Private Sub Workbook_Open()
    Set XlA = Excel.Application
End Sub

Private Sub XlA_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Parent Is ThisWorkbook Then Exit Sub
    Dim Rng As Range
    For Each Rng In Target
        If Rng.Row > 1 Then
            Select Case Rng.Column
                Case 4, 6, 8
                    Dim Qty As Long, Col As Long, Lst As String, i As Long
                    Qty = Sh.Cells(Rng.Row, 4).Value
                    For Col = 6 To 10 Step 2
                        If Col > Rng.Column Then
                            If Qty = 0 Then
                                Lst = "0"
                            Else
                                Lst = "1"
                                For i = 2 To Qty
                                    Lst = Lst & "," & i
                                    If i = 40 Then Exit For
                                Next i
                            End If
                            With Sh.Cells(Rng.Row, Col).Validation
                                .Delete
                                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Lst  '入力規則を設定する
                                .ErrorTitle = "エラー" 'エラー発生時のタイトルを設定する
                                If Col = 6 Then
                                    .ErrorMessage = "入荷数量以内で入力してください。" 'エラーメッセージを設定する
                                Else
                                    .ErrorMessage = "残数量以内で入力してください。"
                                End If
                            End With
                        End If
                        Qty = Qty - Sh.Cells(Rng.Row, Col).Value
                    Next Col
            End Select
        End If
    Next Rng
End Sub

Comments

[Yoshikun_0945]

回答いただきまして誠にありがとうございます。
上記のコードは、ドロップダウンリストをつけるExcelファイルでしょうか？
Excelファイルの書式を操作するためのExcelVBAファイルでしょうか？

[yorozuya]

ドロップダウンリストを動的に設定するプログラムになります。
xlsmブックと同時に開いている別のブックのすべてのシートが対象になります。

[Yoshikun_0945]

かしこまいりました。
後程試してみます。

Answer 2

ドロップダウンリストにて選択できる値を連動させたいのですが、ドロップダウンリストのファイルは.xlsxで可能でしょうか？

マクロなんか使わなくても、名前の定義を可変の範囲に
設定することが可能です。
この辺は、掲示板で質問するくらいなら、
Webで検索した方が、いつ回答が得られるかわからない掲示板で質問するより、
画像付きの解説等がいくつかあると思うので
そちらを見た方が解決が早いかと思います。

それから、数字を入れるだけの為ににドロップダウンリスト的な
ものを使うのは賛成できかねます。
いろいろなサイトでそのような入力をさせられる場面がありますが、
数字のみならテンキーの方がよっぽど入力が楽かと。
あと、ドロップダウンということは、
最低限2回クリックしなければならず、
ましてや40個選択肢があるとしてそのうちの30を探すのも
一苦労ではないですか？
そして、リストのフォント大きさがセルのフォントの大きさ
になるので、選択肢の文字が小さくて選びにくくないですか？
そんなこんなで個人的にすごく使いづらいなという印象です。

なので、入力規則で注意を促すとともに、
条件付き書式設定で色を付けるなりして強調してやるくらいで、
いいのではないかなぁと思います。

あと、エクセルの使い方はエクセルのフォーラムとか掲示板等で、
された方が、VBAも含めて総合的にアドバイスが貰えるのではないか
と思います。