最新単価抽出(ＫＥＹが3つの場合) VBA

Sub 最新単価抽出()

    Dim wsData As Worksheet
    Dim wsOutput As Worksheet
    Dim lastRow As Long
    Dim partNumCol As Long, dimCol As Long, bcCol As Long, dateCol As Long, priceCol As Long
    Dim key As Variant
    Dim priceDict As Object
    Dim maxDateDict As Object
    Dim i As Long
    Dim outputRow As Long
    
    ' データが含まれるシートの設定
    Set wsData = ThisWorkbook.Sheets("Data") ' データが含まれるシートの名前を適宜変更
    
    ' 出力先のシートの設定（新規シートを追加）
    Set wsOutput = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
    
    ' シート名を設定
    wsOutput.Name = "最新単価"
    
    ' 列の設定（部品、項目2、BC、設定日、単価）
    partNumCol = 1 ' 部品の列
    dimCol = 2 ' 寸法の列
    bcCol = 3 ' BCの列
    dateCol = 4 ' 設定日の列
    priceCol = 5 ' 単価の列
    
    ' 最終行を取得
    lastRow = wsData.Cells(wsData.Rows.Count, partNumCol).End(xlUp).row
    
    ' 辞書オブジェクトの作成
    Set priceDict = CreateObject("Scripting.Dictionary")
    Set maxDateDict = CreateObject("Scripting.Dictionary")
    
    ' データの読み込みと最新単価の取得
    For i = 2 To lastRow
        key = wsData.Cells(i, partNumCol) & "_" & wsData.Cells(i, dimCol) ' 部品番号と寸法を組み合わせてキーとする
        If Not priceDict.Exists(key) Then
            priceDict.Add key, wsData.Cells(i, priceCol).Value & "_" & wsData.Cells(i, bcCol).Value ' 寸法とBCを組み合わせて値とする
            maxDateDict.Add key, wsData.Cells(i, dateCol).Value
        Else
            If wsData.Cells(i, dateCol).Value > maxDateDict(key) Then
                priceDict(key) = wsData.Cells(i, priceCol).Value & "_" & wsData.Cells(i, bcCol).Value ' 寸法とBCを組み合わせて値とする
                maxDateDict(key) = wsData.Cells(i, dateCol).Value
            End If
        End If
    Next i
    
    ' 出力先シートに最新単価情報を書き込む
    outputRow = 2 ' 出力開始行
    wsOutput.Cells(1, 1).Value = "部品＋項目2"
    wsOutput.Cells(1, 2).Value = "BC"
    wsOutput.Cells(1, 3).Value = "更新日"
    wsOutput.Cells(1, 4).Value = "単価"
    For Each key In priceDict.Keys
        wsOutput.Cells(outputRow, 1).Value = key ' 部品と項目2を組み合わせて出力
        wsOutput.Cells(outputRow, 2).Value = Split(priceDict(key), "_")(1)
        wsOutput.Cells(outputRow, 3).Value = maxDateDict(key)
        wsOutput.Cells(outputRow, 4).Value = Split(priceDict(key), "_")(0)
        outputRow = outputRow + 1
    Next key
    
    ' 辞書オブジェクトの解放
    Set priceDict = Nothing
    Set maxDateDict = Nothing
シート連番
End Sub
Sub シート連番()
    Dim ws As Worksheet
    Dim i As Integer
    i = 1
    For Each ws In ThisWorkbook.Sheets
        If Left(ws.Name, 2) = "最新" Then
            ws.Name = Left(ws.Name, 4) & Format(i, "00")
            i = i + 1
        End If
    Next ws
End Sub