| |
▼さと さん：
二番煎じですが。
Sub Test()
Dim dic As Object
Dim c As Range
Dim w As Variant
Dim tmp As Variant
Dim mx As Long
Set dic = CreateObject("Scripting.Dictionary")
For Each c In Range("D2", Range("D" & Rows.Count).End(xlUp))
dic(c.Value) = Array(dic.Count + 1, 0)
Next
ReDim w(1 To dic.Count, 1 To Columns.Count)
For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp))
If dic.exists(c.Value) Then
tmp = dic(c.Value)
tmp(1) = tmp(1) + 1
w(tmp(0), tmp(1)) = c.Offset(, 1).Value
w(tmp(0), tmp(1) + 1) = c.Offset(, 2).Value
If tmp(1) + 1 > mx Then mx = tmp(1) + 1
tmp(1) = tmp(1) + 2
dic(c.Value) = tmp
End If
Next
ReDim Preserve w(1 To UBound(w, 1), mx)
Range("E2").Resize(UBound(w, 1), UBound(w, 2)).Value = w
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
