VBA 配列 一番若い日付 調べる方法

Question

配列の中に日付やその他数値を含む値が格納されており、その配列の中から一番若い日付を取得する方法を教えて頂けないでしょうか。

在庫の管理上、コードと賞味期限およびその個数を管理しております。
そのリストをdictionaryで取得し、それぞれのコードをキーとして賞味期限と個数をアイテムに配列形式で格納しております。

そこで特定のキーに格納されてるアイテムである賞味期限と個数の配列から一番若い日付を取得する方法はございますでしょうか。

配列形式のアイテムに対して、worksheet関数のminを使用しましたが、
①賞味期限のシリアル値よりも個数の方が数値としては小さいため一番少ない個数が取得されてしまうこと、
②そもそもアイテムの配列形式として格納されている日付が数値として認識されず、個数が全て空欄だったとしても０が返される
という２点が問題として起こってしまいました。

以下にサンプルコードとExcelのスクショを掲載致しましたので、参考にして頂けますと幸いです。
なお、今回は便宜上、キーとなる特定のコードは 11行目 の 6018 と致しました。

Sub dictionaryArray()

Dim myDictionary As Object
Set myDictionary = CreateObject("Scripting.Dictionary")

Dim foundCd As Range
Set foundCd = Cells.Find(what:="コード", lookat:=xlWhole)
Dim i As Long, j As Long, n As Long
Dim BBarray() As Variant

'コードをKeyとして、コードに連なる賞味期限、個数をItemとして配列形式に格納
For i = foundCd.Row + 1 To Cells(Rows.Count, foundCd.column).End(xlUp).Row
    'UBoundでエラーがでないように再定義。
    ReDim BBarray(0) As Variant
    For j = foundCd.column + 1 To foundCd.End(xlToRight).column
        n = UBound(BBarray) + 1
        ReDim Preserve BBarray(n)
        BBarray(n) = Cells(i, j).Value  'BBarray(0)には何も格納されていないことになる。
    Next j
'    dictionaryにコードとその賞味期限、個数を登録。
    myDictionary.Add Cells(i, foundCd.column).Value, BBarray
Next i

'dictionaryのKey、Itemをインデックスで指定できるように変数に格納。
Dim BBkey As Variant, BBitem As Variant
BBkey = myDictionary.keys
BBitem = myDictionary.items

Dim cd As Long
cd = 6018

'cdのBBkeyのインデックスを調べる｡
Dim cdIndex As Long
For cdIndex = 0 To UBound(BBkey)
    If (BBkey(cdIndex) = cd) Then
        Exit For
    End If
Next cdIndex

Debug.Print Application.WorksheetFunction.Min(BBitem(cdIndex))

End Sub

お手数おかけしますが、教えて頂けますと幸いです。

Comments

[xail2222]

データの持ち方を変えるのはありですか？って書いてあった。返答きたから、書き直しました！

[tttkkk]

私の理解が足らず、申し訳ないのですが、
データの持ち方を変えるとはどういうことでしょうか。
このファイルのレイアウト以外は考えたことが無く、もしマクロを走らせる上で、改善した方が良い部分がありましたら、その点も考慮したいとは思います。

[xail2222]

シートのレイアウトは変える必要はないとおもいます。シートのデータの読み込んでプログラムの変数として持つときに、その持ち方を変えるのはどうですか？という意味です。

[xail2222]

とりあえず、一つ回答入ってるので私も回答として、参考になるかどうかわからないけど
サンプルプログラムを提示してみます。

Answer 1

下記のような方針でコーディングしてみました。

1. 日付と個数という異なるデータを一つの配列に入れるのがそもそも無理があるので、それぞれ別の配列に格納する。

　

1. 日付はminでは0になるようなので、シリアル値で配列に格納する。シリアル値は Value2 プロパティで取得できます。

　

1. ２つの配列はArray関数で一つの配列にまとめて、Dictionary に格納する。

Sub dictionaryArray()
    Dim myDictionary As Object
    Set myDictionary = CreateObject("Scripting.Dictionary")

    Dim foundCd As Range
    Set foundCd = Cells.Find(what:="コード", lookat:=xlWhole)

    Dim leftCol As Long, rightCol As Long
    leftCol = foundCd.Column
    rightCol = foundCd.End(xlToRight).Column

    Dim kigen() As Variant, kosu() As Variant

    'コードをKeyとして、コードに連なる賞味期限、個数をItemとして配列形式に格納
    Dim i As Long, j As Long
    For i = foundCd.Row + 1 To Cells(Rows.Count, foundCd.Column).End(xlUp).Row
        ReDim kigen((rightCol - leftCol) / 2)
        ReDim kosu((rightCol - leftCol) / 2)

        For j = leftCol + 1 To rightCol Step 2
            kigen((j - leftCol) \ 2) = Cells(i, j).Value2
            kosu((j - leftCol) \ 2) = Cells(i, j + 1).Value
        Next j
        '    dictionaryにコードとその賞味期限、個数を登録。
        myDictionary.Add Cells(i, leftCol).Value, Array(kigen, kosu)
    Next i

    Dim cd As Long
    cd = 3808

    If myDictionary.exists(cd) Then
        kigen = myDictionary(cd)(0)
        Debug.Print "最古賞味期限:" & CDate(Application.WorksheetFunction.Min(kigen))
    Else
        Debug.Print  "コード" & cd & "は見つかりません。"
    End If

End Sub

Comments

[tttkkk]

ご丁寧にありがとうございます！。
お1つ質問になるのですが、今回賞味期限を取得したいということで、最後の方のコードが

If myDictionary.exists(cd) Then
kigen = myDictionary(cd)(0)
Debug.Print "最古賞味期限:" & CDate(Application.WorksheetFunction.Min(kigen))
Else
Debug.Print "コード" & cd & "は見つかりません。"
End If

と書いて頂けております。
これを今度個数を取得したいとなった場合には
kigen = myDictionary(cd)(0)
の部分をどのように変更するべきなのでしょうか。

現状、個数を取得して活用する予定はございませんが、
dictionaryの理解を深めたいと思い、お伺い致しました。
教えていただけますでしょうか。

[hatena19]

myDictionary(cd)(1) で個数の配列を取得できます。

DictionaryのItemに賞味期限の配列と個数の配列を Array(kigen, kosu) で一つの配列にしています。

[tttkkk]

なるほど。
本当にご丁寧にありがとうございます。
非常に勉強になりました。

Answer 2

賞味期限と個数が順番に入っているのなら、
そこから賞味期限の要素だけ取り出してから比較すればいいのでは。

Dim arr
arr = BBitem(cdIndex)
Redim arrKigen(1 To Ubound(arr) / 2)

Dim k
For k = 1 To Ubound(arrKigen)
 arrKigen(k) = arr(k * 2 - 1)
Next

Debug.Print Application.WorksheetFunction.Min(arrKigen)

Comments

[tttkkk]

申し訳ありません。
記載して頂いたコードで走らせてみたのですが、最後の
Application.WorksheetFunction.Min(arrKigen)
の部分でどしても０が変えさせてしまいました。
確かにarrkigenの予想としては、仰る通り日付しか入っていないのですが、０が返されていまいます。

これは配列であるBBitemの時点で賞味期限（日付）も個数（数値）を一緒に格納してしまっているので、
このBBitemから賞味期限（日付）だけを抜き出しても、VBAでは日付とは認識されたないということになるのでしょうか。

[jinoji]

xail2222さん,hatena19さんの回答にあるように
セルからの取得時にValue2を使う、もしくは変数への格納時にcLngする、とすればきっと大丈夫な気が。
たとえば、上のコードを ​arrKigen(k) = cLng(arr(k * 2 - 1)) とするとかでどうですか。

[tttkkk]

やはり一旦どこかで日付に変換するという処理が必要なのですね。
日付の扱い方は難しいとよく言われますが、その所以がよく分かった気がします。
ご回答して頂きありがとうございました。

[tttkkk]

日付に ではなく 日付を でした。
失礼致しました。

Answer 3

よくわかってないけど回答します！
（１）日付のminは取れないみたいなのでClngで数値にしてminとってその後表示とかする時にCDateする！

（２）賞味期限と個数がdcitionaryの値として同じ配列に入っているのをやめて
dictionary:コード→[dictionary:賞味期限→個数] という形にする

サンプルコードを書いてみます。

Public Sub test()
    ' データ準備
    Dim tDic As Scripting.Dictionary
    Set tDic = New Scripting.Dictionary
    Dim tDicSub As Scripting.Dictionary
    Set tDicSub = New Scripting.Dictionary
    tDic.Add 1000, tDicSub
    tDicSub.Add CLng(CDate("2021/2/5")), 1
    tDicSub.Add CLng(CDate("2021/2/3")), 2
    tDicSub.Add CLng(CDate("2021/2/4")), 3
    tDicSub.Add CLng(CDate("2021/2/6")), 4
    
    ' 最小の日付（整数値）を求める
    Dim tMinLngDate As Long
    tMinLngDate = Excel.WorksheetFunction.Min(tDic.Item(1000).Keys)

    ' 最小の日付とその個数を表示    
    Debug.Print CDate(tMinLngDate) & ":" & tDic.Item(1000).Item(tMinLngDate)
End Sub

という感じなのですが、使えないでしょうか！

あ、後参考までに

Dim BBkey As Variant, BBitem As Variant
BBkey = myDictionary.keys
BBitem = myDictionary.items

Dim cd As Long
cd = 6018

'cdのBBkeyのインデックスを調べる｡
Dim cdIndex As Long
For cdIndex = 0 To UBound(BBkey)
    If (BBkey(cdIndex) = cd) Then
        Exit For
    End If
Next cdIndex

Debug.Print Application.WorksheetFunction.Min(BBitem(cdIndex))

とやってますが、これは

Dim cd As Long
cd = 6018
Debug.Print Application.WorksheetFunction.Min(myDictionary.item(cd))

これと同じことです！　のはずです！

Comments

[tttkkk]

私自身のコードを修正して頂いてありがとうございます。
ご指摘して頂いた通りで、無駄に for cdIndex を回していることに気付けておりませんでした。

またdictionaryにさらにdictionaryを追加するという方法も教えて頂きありがとうございます。
私自身まだdictionaryを勉強し始めて理解が浅く、dictionaryを二重するというのは、私自身がコードを振り返った時の可読性の観点から少し控えようと思います。
しかしdictionaryにdictionaryを登録するということは全く思いつかなかったアイデアでしたので、よりdictionaryの理解を深めたのち、チャレンジ致します。

Answer 4

MinIfsが使えないかな、と考えたけど、引数がRangeでないといけないっぽいので、何かひと工夫が必要ですね。
たとえばこんな感じ？（試してはいないですが。）

    ReDim BBarray(0) As Variant
    Dim dataRange As Range
    Set dataRange = Range(foundCd.Offset(, 1), foundCd.End(xlToRight))
    BBarray(0) = WorksheetFunction.MinIfs(dataRange, dataRange, ">40000")