【VBA】Excelで、製品の販売価格の更新情報を持つマスタから、いろいろな販売日の価格を取得する

難しく書いたけど、要するに
ある製品の販売価格が、不定期に変わっていて、その履歴が残っている。
じゃあ、「任意のタイミングでの販売価格はいくらか？」を取得するというもの。

元ネタはこちら
https://twitter.com/ia02003812/status/1122857099669598209

　ワークシート関数だけでも出来そうだけど、データ件数が多いとなるとレスポンスが悪そう。
　VLookUpでは、複数条件で絞り込めなさそうなので多分NG.
　MAXIFS を使えば出来そうだけど、うちのExcelは 2013 なので使えない。
　他にも方法はあるのだろうけど、今回は（今回も？）VBAで・・・

データは下に載せたような感じ。
いつもの如く、乱数使いまくって・・・
データ作成のコードも下の方に載せてあるので、興味のある方はどうぞ。
同じデータは作れませんけど、近いものは作れるはずなので・・・

価格履歴：各製品の販売価格の更新情報を持つマスタ（製品名、販売価格、適用開始年月日）

重要：価格履歴データは適用開始日が昇順でソートされていないと、掲載したコードは正しく動きません。

販売トラン：各製品の販売実績データ（販売日、製品名、販売数）

「データの名称が、下記のコード中の名称と違う」とか突っ込まないで下さい。

問題点としては、販売トランにある販売日が、価格履歴の価格適用開始日と一致する保証がないので、通常の完全一致の検索が出来ない。
これを解決する手段が必要。

これについては、Dictionary を使用して、以下のようにデータを格納し、その中から該当データを取得出来るようにした。
Key：製品名
Item：「販売価格」、「適用開始年月日」をペアにした物の配列

Dictionary への動的配列の格納は、以前やっているので特に問題はない。
z1000s.hatenablog.com

▶販売価格 更新処理コード

Private Const MASTER_SHEET_NAME     As String = "商品マスタ"
Private Const TRAN_SHEET_NAME       As String = "販売データ"

Private Const HEADER_ROWS   As Long = 1

Private Const MASTER_ITEM_NAME_COL          As String = "A"
Private Const MASTER_ITEM_UNIT_PRICE_COL    As String = "B"
Private Const MASTER_START_DATE_COL         As String = "C"

Private Const TRAN_DATE_COL                 As String = "A"
Private Const TRAN_ITEM_NAME_COL            As String = "B"
Private Const TRAN_PRICE_COL                As String = "C"
Private Const TRAN_SALES_VOLUME_COL         As String = "D"
Private Const TRAN_TOTAL_PRICE_COL          As String = "E"


Private Const ITEM_NAME_PREFIX          As String = "商品"

Private Const MIN_PRICE                 As Long = 100
Private Const MAX_PRICE                 As Long = 99999

Private Const MASTER_MIN_UPDATE_SPAN    As Long = 7
Private Const MASTER_MAX_UPDATE_SPAN    As Long = 120

Private Const MASTER_MIN_UPDATE_COUNT   As Long = 20
Private Const MASTER_MAX_UPDATE_COUNT   As Long = 60

Private Const MASTER_ITEMS_COUNT        As Long = 200


Private Const TRAN_MIN_UPDATE_SPAN      As Long = 0
Private Const TRAN_MAX_UPDATE_SPAN      As Long = 1

Private Const TRAN_MIN_SALES_VOLUME     As Long = 1
Private Const TRAN_MAX_SALES_VOLUME     As Long = 999


Private Const BEGIN_DATE    As Date = #1/1/2010#

Private Const TRAN_DATA_COUNT   As Long = 10000


Private dicItemInfo_        As Dictionary


'販売データの単価更新
Public Sub updateSalesVolume()

    Dim ws          As Worksheet
    Dim lRow        As Long
    Dim dtDate      As Date
    Dim sItemName   As String
    Dim lItemsCount As Long
    Dim vPrice()    As Variant

    Dim sgStart     As Single
    Dim sgStop      As Single

    sgStart = Timer

    Call initMasterInfo

    Application.ScreenUpdating = True

    lRow = HEADER_ROWS + 1

    Set ws = ThisWorkbook.Worksheets(TRAN_SHEET_NAME)

    With ws
        lItemsCount = .Range(TRAN_ITEM_NAME_COL & CStr(lRow)).End(xlDown).Row - HEADER_ROWS

        ReDim vPrice(lItemsCount - 1)

        lItemsCount = 0

        sItemName = .Range(TRAN_ITEM_NAME_COL & CStr(lRow)).Value
        dtDate = .Range(TRAN_DATE_COL & CStr(lRow)).Value

        Do Until sItemName = ""
            vPrice(lItemsCount) = getItemPrice(sItemName, dtDate)

            lItemsCount = lItemsCount + 1

            lRow = lRow + 1

            sItemName = .Range(TRAN_ITEM_NAME_COL & CStr(lRow)).Value
            dtDate = .Range(TRAN_DATE_COL & CStr(lRow)).Value
        Loop

        .Range(TRAN_PRICE_COL & CStr(HEADER_ROWS + 1)).Resize(UBound(vPrice) + 1) = WorksheetFunction.Transpose(vPrice)
    End With

    Application.ScreenUpdating = True

    sgStop = Timer

    Debug.Print "Done.  " & Format$(sgStop - sgStart, "0.00") & " [sec.]"

End Sub

'販売単価個別取得
Public Function getItemPrice(ByVal sItemName As String, ByVal dtDate As Date) As Long

    Dim vaItemInfo  As Variant
    Dim lSubscriptU As Long
    Dim i           As Long

    getItemPrice = 0

    If Not dicItemInfo_.Exists(sItemName) Then
        Exit Function
    ElseIf dicItemInfo_.Item(sItemName)(0)(0) > dtDate Then
        Exit Function
    End If

    '商品名をキーに、価格情報データ配列を取得
    vaItemInfo = dicItemInfo_.Item(sItemName)

    lSubscriptU = UBound(vaItemInfo)

    If lSubscriptU > 0 Then
        '２件以上の要素がある場合
        '最終の価格適用日以降の日付なら、最終価格を返す
        If dtDate >= vaItemInfo(lSubscriptU)(0) Then
            getItemPrice = vaItemInfo(lSubscriptU)(1)

            Exit Function
        End If

        '２番めからループ
        For i = 1 To lSubscriptU
            If dtDate < vaItemInfo(i)(0) Then
                '適用開始日以前の日付であれば、１つ前の価格を返す
                getItemPrice = vaItemInfo(i - 1)(1)

                Exit For
            End If
        Next i
    ElseIf UBound(vaItemInfo) = 0 Then
        'データが１件のみ
        If dtDate >= vaItemInfo(0)(0) Then
            '適用開始日以降の日付なら、登録済み価格を返す
            getItemPrice = vaItemInfo(0)(1)
        End If
    End If

End Function

'個別単価取得用Dictionary初期化
Private Sub initMasterInfo()

    Dim ws              As Worksheet
    Dim sItemName       As String
    Dim vaItemInfo(1)   As Variant
    Dim vaIi            As Variant
    Dim lSubscriptU     As Long
    Dim lRow            As Long

    Set ws = ThisWorkbook.Worksheets(MASTER_SHEET_NAME)

    'Dictionaryの初期化
    If dicItemInfo_ Is Nothing Then
        Set dicItemInfo_ = New Dictionary
    Else
        'データが生成済みなら、全削除
        dicItemInfo_.RemoveAll
    End If

    'データ開始行
    lRow = HEADER_ROWS + 1

    With ws
        '品名
        sItemName = .Cells(lRow, MASTER_ITEM_NAME_COL).Value

        Do Until sItemName = ""
            '適用開始日
            vaItemInfo(0) = .Cells(lRow, MASTER_START_DATE_COL).Value
            '価格
            vaItemInfo(1) = .Cells(lRow, MASTER_ITEM_UNIT_PRICE_COL).Value

            If dicItemInfo_.Exists(sItemName) Then
                '登録済み品名なら、データ配列を一旦取り出す
                vaIi = dicItemInfo_(sItemName)

                lSubscriptU = UBound(vaIi) + 1

                '要素追加分拡張
                ReDim Preserve vaIi(lSubscriptU)
            Else
                lSubscriptU = 0

                '配列初期化
                ReDim vaIi(lSubscriptU)
            End If

            '配列にデータを追加
            vaIi(lSubscriptU) = vaItemInfo

            'Dictionaryに戻す
            dicItemInfo_(sItemName) = vaIi

            lRow = lRow + 1

            sItemName = .Cells(lRow, MASTER_ITEM_NAME_COL).Value
        Loop
    End With

End Sub

テスト用データ生成コードで使っている定数とかは、上の「販売価格 更新処理コード」に記載されているので、上のコードと同じモジュールに貼り付けて使って下さい。

▶テスト用データ生成コード

'商品価格マスタ生成
Public Sub createMaterDatas()

    Dim ws          As Worksheet
    Dim lRow        As Long
    Dim sItemName   As String
    Dim dtUpdate    As Date
    Dim lPrice      As Long
    Dim lUpdateSpan As Long

    Dim lMaxUpdate  As Long

    Dim sTargetRange As String
    Dim i           As Long
    Dim j           As Long

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets(MASTER_SHEET_NAME)

    lRow = HEADER_ROWS + 1

    Randomize

    With ws
        .Range("A" & CStr(HEADER_ROWS + 1)).CurrentRegion.ClearContents

        .Range(MASTER_ITEM_NAME_COL & CStr(HEADER_ROWS)).Value = "商品名"
        .Range(MASTER_ITEM_UNIT_PRICE_COL & CStr(HEADER_ROWS)).Value = "価格"
        .Range(MASTER_START_DATE_COL & CStr(HEADER_ROWS)).Value = "適用開始年月日"

        For i = 1 To MASTER_ITEMS_COUNT
            sItemName = ITEM_NAME_PREFIX & Format$(i, "00000")
            lPrice = Int((MAX_PRICE - MIN_PRICE + 1) * Rnd) + MIN_PRICE
            dtUpdate = BEGIN_DATE

            .Range(MASTER_ITEM_NAME_COL & CStr(lRow)).Value = sItemName
            .Range(MASTER_ITEM_UNIT_PRICE_COL & CStr(lRow)).Value = lPrice
            .Range(MASTER_START_DATE_COL & CStr(lRow)).Value = dtUpdate

            lMaxUpdate = Int((MASTER_MAX_UPDATE_COUNT - MASTER_MIN_UPDATE_COUNT + 1) * Rnd) + MASTER_MIN_UPDATE_COUNT

            lRow = lRow + 1

            For j = 2 To lMaxUpdate
                lPrice = Int((MAX_PRICE - MIN_PRICE + 1) * Rnd) + MIN_PRICE

                lUpdateSpan = Int((MASTER_MAX_UPDATE_SPAN - MASTER_MIN_UPDATE_SPAN + 1) * Rnd) + MASTER_MIN_UPDATE_SPAN
                dtUpdate = DateAdd("d", lUpdateSpan, dtUpdate)

                .Range(MASTER_ITEM_NAME_COL & CStr(lRow)).Value = sItemName
                .Range(MASTER_ITEM_UNIT_PRICE_COL & CStr(lRow)).Value = lPrice
                .Range(MASTER_START_DATE_COL & CStr(lRow)).Value = dtUpdate

                lRow = lRow + 1
            Next j
        Next i

        '適用開始年月日順にソート
        With .Sort
            .SortFields.Clear

            sTargetRange = MASTER_START_DATE_COL & CStr(HEADER_ROWS) & ":" & MASTER_START_DATE_COL & CStr(lRow - 1)
            .SortFields.Add Key:=ws.Range(sTargetRange), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

            sTargetRange = MASTER_ITEM_NAME_COL & CStr(HEADER_ROWS) & ":" & MASTER_ITEM_NAME_COL & CStr(lRow - 1)
            .SortFields.Add Key:=ws.Range(sTargetRange), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

            sTargetRange = MASTER_ITEM_NAME_COL & CStr(HEADER_ROWS) & ":" & MASTER_START_DATE_COL & CStr(lRow - 1)
            .SetRange ws.Range(sTargetRange)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

    Application.ScreenUpdating = True

    Debug.Print "Done."

End Sub


'販売データ生成
Public Sub createTranDatas()

    Dim ws          As Worksheet
    Dim lRow        As Long
    Dim dtDate      As Date
    Dim lDateOffset As Long
    Dim lItemIndex  As Long
    Dim sItemName   As String
    Dim lSalesVolume    As Long

    Dim i           As Long

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets(TRAN_SHEET_NAME)

    lRow = HEADER_ROWS + 1

    dtDate = BEGIN_DATE

    Randomize

    With ws
        .Range("A" & CStr(HEADER_ROWS + 1)).CurrentRegion.ClearContents

        .Range(TRAN_DATE_COL & CStr(HEADER_ROWS)).Value = "日付"
        .Range(TRAN_ITEM_NAME_COL & CStr(HEADER_ROWS)).Value = "商品名"
        .Range(TRAN_PRICE_COL & CStr(HEADER_ROWS)).Value = "販売価格"
        .Range(TRAN_SALES_VOLUME_COL & CStr(HEADER_ROWS)).Value = "販売数量"
        .Range(TRAN_TOTAL_PRICE_COL & CStr(HEADER_ROWS)).Value = "売上金額"

        For i = 1 To TRAN_DATA_COUNT
            lDateOffset = Int((TRAN_MAX_UPDATE_SPAN - TRAN_MIN_UPDATE_SPAN + 1) * Rnd) + TRAN_MIN_UPDATE_SPAN

            '日付
            dtDate = DateAdd("d", lDateOffset, dtDate)
            .Range(TRAN_DATE_COL & CStr(lRow)).Value = dtDate

            '商品名
            lItemIndex = Int(MASTER_ITEMS_COUNT * Rnd) + 1
            sItemName = ITEM_NAME_PREFIX & Format$(lItemIndex, "00000")
            .Range(TRAN_ITEM_NAME_COL & CStr(lRow)).Value = sItemName

            '販売数量
            lSalesVolume = Int((TRAN_MAX_SALES_VOLUME - TRAN_MIN_SALES_VOLUME + 1) * Rnd) + TRAN_MIN_SALES_VOLUME
            .Range(TRAN_SALES_VOLUME_COL & CStr(lRow)).Value = lSalesVolume

            lRow = lRow + 1
        Next i

    End With

    Application.ScreenUpdating = True

    Debug.Print "Done."

End Sub

実行結果

製品種類数：200
価格履歴件数：8,072
販売データ件数：10,000

所要時間：0.8 ～ 0.9 秒

でした。

遅くはないと思うけど、比べる物が無いので・・・

おまけ

「(0)(0)って何？」という方向けの、"よくわからないかもしれない" 解説のようなもの。

dicItemInfo_.Item(sItemName)(0)(0)
vaItemInfo(0)(0)

配列の要素が配列なので、こういう記述になります。ハイ。

例えば
a(2)
という配列があるとして、
a(0)の要素が、b という配列の場合、b(0)を参照するには
a(0)(0)
という指定をします。

Public Sub foo()

    Dim a(2)
    Dim b(1)

    b(0) = "B00"
    b(1) = "B01"

    a(0) = b

    b(0) = "B10"
    b(1) = "B11"

    a(1) = b

    Debug.Print "A00 : " & a(0)(0)
    Debug.Print "A01 : " & a(0)(1)

    Debug.Print "A10 : " & a(1)(0)
    Debug.Print "A11 : " & a(1)(1)

End Sub

実行結果

call foo
A00 : B00
A01 : B01
A10 : B10
A11 : B11

本当は、Dictionary の Item には、構造体（ユーザー定義型）を入れたかったんですよ。
でも、出来ないみたいだったので、やむなく配列で代用しました。
その結果がこれです。