Sub 抽出と取りまとめ()
Dim ws原本 As Worksheet
Dim ws結果 As Worksheet
Dim dict As Object
Dim lastRow As Long
Dim i As Long
Dim key As Variant
' シートの設定
Set ws原本 = ThisWorkbook.Sheets("Sheet1") ' オリジナルデータがあるシート名
Set ws結果 = ThisWorkbook.Sheets("Sheet2") ' 結果をまとめるシート名
' 辞書の初期化
Set dict = CreateObject("Scripting.Dictionary")
' 最終行を取得
lastRow = ws原本.Cells(ws原本.Rows.Count, "A").End(xlUp).Row
' データを辞書に格納
For i = 2 To lastRow ' ヘッダーがある場合は1からではなく2から始める
key = ws原本.Cells(i, 1).Value & "_" & ws原本.Cells(i, 2).Value
If Not dict.Exists(key) Then
dict.Add key, Array(ws原本.Cells(i, 3).Value, ws原本.Cells(i, 4).Value) ' 日付と単価を配列に格納
Else
' 日付がより新しい場合、単価を更新
If ws原本.Cells(i, 3).Value > dict(key)(0) Then
' 日付の比較を正確に行うために、Date型に変換する
' If CDate(ws原本.Cells(i, 3).Value) > CDate(dict(key)(0)) Then
dict(key) = Array(ws原本.Cells(i, 3).Value, ws原本.Cells(i, 4).Value)
End If
End If
Next i
' 結果を書き込む
ws結果.Cells.Clear
ws結果.Range("A1").Value = "項目1"
ws結果.Range("B1").Value = "項目2"
ws結果.Range("C1").Value = "最新日付"
ws結果.Range("D1").Value = "最新単価"
i = 2
For Each key In dict.keys
ws結果.Cells(i, 1).Value = Split(key, "_")(0)
ws結果.Cells(i, 2).Value = "'" & Split(key, "_")(1)
ws結果.Cells(i, 2).Value = Split(key, "_")(1)
ws結果.Cells(i, 3).Value = dict(key)(0)
ws結果.Cells(i, 4).Value = dict(key)(1)
i = i + 1
Next key
End Sub
抽出と取りまとめ
