難しく書いたけど、要するに
ある製品の販売価格が、不定期に変わっていて、その履歴が残っている。
じゃあ、「任意のタイミングでの販売価格はいくらか？」を取得するというもの。
元ネタはこちら
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
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)
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
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 秒
でした。
遅くはないと思うけど、比べる物が無いので・・・
おまけ
多分、見たことのない人が多いであろう物
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 には、構造体（ユーザー定義型）を入れたかったんですよ。
でも、出来ないみたいだったので、やむなく配列で代用しました。
その結果がこれです。
