Sub ExtractLatestPrices4()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim partNumbers As Object
Dim key As String
Dim maxDate As Date
Dim latestPrice As Double
Dim newData() As Variant
Dim i As Long
Dim newRow As Long
' ソースとなるワークシートを設定
Set wsSource = ThisWorkbook.Sheets("Data2") ' Sheet1 を適切なシート名に変更
' ターゲットとなる新しいワークシートを追加
Set wsTarget = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
wsTarget.Name = "最新単価" ' ExtractedPrices を適切なシート名に変更
' 最終行を取得
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).row ' 項目が記載された列に合わせて変更
' 部番と寸法と工程とBCをキーとして最新単価を抽出
Set partNumbers = CreateObject("Scripting.Dictionary")
' 配列をリサイズ
ReDim newData(1 To lastRow, 1 To 5)
' データを読み取りながら処理
newRow = 1
For i = 2 To lastRow ' ヘッダーがある場合は1からではなく2から始める
' 部番と寸法と工程とBCをキーとして生成
key = wsSource.Cells(i, 1).Value & "_" & CStr(wsSource.Cells(i, 2).Value) & "_" & wsSource.Cells(i, 3).Value & "_" & wsSource.Cells(i, 4).Value
' 最新単価を取得
If Not partNumbers.Exists(key) Then
' 初めてのキーの場合は単価を追加
partNumbers.Add key, wsSource.Cells(i, 6).Value
' 配列にデータを追加
newData(newRow, 1) = wsSource.Cells(i, 1).Value & "_" & CStr(wsSource.Cells(i, 2).Value) ' 項目1と項目2を結合
newData(newRow, 2) = wsSource.Cells(i, 3).Value ' 項目3
newData(newRow, 3) = wsSource.Cells(i, 4).Value ' 項目4
newData(newRow, 4) = wsSource.Cells(i, 5).Value ' 設定日
newData(newRow, 5) = wsSource.Cells(i, 6).Value ' 単価
newRow = newRow + 1
Else
' 既に同じキーが存在する場合は日付を比較して最新単価を更新
If wsSource.Cells(i, 5).Value > maxDate Then
partNumbers(key) = wsSource.Cells(i, 6).Value
' 配列にデータを更新
newData(newRow, 1) = wsSource.Cells(i, 1).Value & "_" & CStr(wsSource.Cells(i, 2).Value) ' 項目1と項目2を結合
newData(newRow, 2) = wsSource.Cells(i, 3).Value ' 項目3
newData(newRow, 3) = wsSource.Cells(i, 4).Value ' 項目4
newData(newRow, 4) = wsSource.Cells(i, 5).Value ' 設定日
newData(newRow, 5) = wsSource.Cells(i, 6).Value ' 単価
End If
End If
Next i
' 配列を新しいワークシートに転記
wsTarget.Range("A1").Resize(UBound(newData, 1), UBound(newData, 2)).Value = newData
'シート連番
End Sub
最新のもの抽出(KEYが4つの場合) VBA
