Sub KEYを作って最新のもの抽出()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim dict As Object
Dim dictKey As Variant ' ディクショナリのキーを格納する変数
' シート1とシート2を設定
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
' シート2を初期化
ws2.Cells.Clear
' シート1の最終行を取得
lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
' ディクショナリを作成
Set dict = CreateObject("Scripting.Dictionary")
' シート1からデータを読み込み
For i = 2 To lastRow
Dim 項目1 As String
項目1 = Trim(ws1.Cells(i, 1).Value) ' 項目1を文字列として取得
Dim 項目2 As String
項目2 = Format(ws1.Cells(i, 2).Value, "000") ' 3桁のゼロ埋め形式で項目2を取得
Dim 項目3 As String
項目3 = Trim(ws1.Cells(i, 3).Value) ' 項目3を文字列として取得
dictKey = 項目1 & "_" & 項目2 & "_" & 項目3 ' 項目1_項目2_項目3
If Not dict.exists(dictKey) Then
Set dict(dictKey) = CreateObject("Scripting.Dictionary")
End If
' 内部のディクショナリを取得
Dim innerDict As Object
Set innerDict = dict(dictKey)
Dim 項目4 As String
項目4 = Format(ws1.Cells(i, 4).Value, "000") ' 3桁のゼロ埋め形式で項目4を取得
Dim innerKey As Variant
innerKey = 項目4 & "_" & Trim(ws1.Cells(i, 6).Value) ' 項目4と日付を組み合わせてキーを作成
If Not innerDict.exists(innerKey) Then
innerDict(innerKey) = Array(項目1, 項目2, 項目3, 項目4, ws1.Cells(i, 5).Value, ws1.Cells(i, 6).Value)
End If
Next i
' シート2にヘッダーを設定
ws2.Cells(1, 1).Value = "項目1"
ws2.Cells(1, 2).Value = "項目2"
ws2.Cells(1, 3).Value = "項目3"
ws2.Cells(1, 4).Value = "項目4"
ws2.Cells(1, 5).Value = "単価"
ws2.Cells(1, 6).Value = "適用日"
' ディクショナリからデータを抽出し、シート2に書き込み
j = 2
For Each dictKey In dict.Keys
Dim maxKey As String
Dim max項目4 As Long
Dim max適用日 As Date
max項目4 = -1
max適用日 = DateSerial(1900, 1, 1) ' Excelで扱える最小の日付
' グループ内の最大項目4と最新適用日を見つける
For Each innerKey In dict(dictKey).Keys
Dim values As Variant
values = Split(innerKey, "_")
Dim項4 As Long
Dim 適用日 As Date
項4 = CLng(values(0))
適用日 = CDate(values(1))
If項4 > max項目4 Or (職 = max項目4 And 適用日 > max適用日) Then
max項目4 =項4
max適用日 = 適用日
maxKey = innerKey
End If
Next innerKey
' シート2に書き込み
Dim outputData As Variant
outputData = dict(dictKey)(maxKey)
ws2.Cells(j, 1).Resize(1, 6).Value = outputData
j = j + 1
Next dictKey
Call 表示3桁
MsgBox "データ抽出が完了しました。", vbInformation
End Sub
KEYを作って最新のもの抽出
