This will work for your example worksheet.
Sub abc()
Const shData As String = "Sheet1"
Const shOutput As String = "Sheet2"
Dim arr, w, key
Dim i As Long, ii As Long
With Worksheets(shData)
arr = .Range("a1").CurrentRegion.Value
End With
With CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
If Not .exists(arr(i, 3)) Then
ReDim w(UBound(arr, 2) - 1)
For ii = 1 To UBound(arr, 2)
w(ii - 1) = arr(i, ii)
Next
Else
w = .Item(arr(i, 3))
For ii = 7 To UBound(arr, 2)
ReDim Preserve w(UBound(w) + 1)
w(UBound(w)) = arr(i, ii)
Next
End If
.Item(arr(i, 3)) = w
Next
i = 2
For Each key In .keys
If ii < UBound(.Item(key)) Then ii = UBound(.Item(key)) - 5
Worksheets(shOutput).Cells(i, 1).Resize(, UBound(.Item(key)) + 1) = .Item(key)
i = i + 1
Next
End With
With Worksheets(shData)
.Range("a1:f1").Copy Worksheets(shOutput).Range("a1")
.Range("g1", .Cells(1, Columns.Count).End(xlToLeft)).Copy Worksheets(shOutput).Range("g1")
End With
With Worksheets(shOutput)
.Range("G1:P1").AutoFill Destination:=.Range("G1").Resize(, ii), Type:=xlFillCopy
End With
End Sub
LinkBack URL
About LinkBacks
bhavt010785 
Register To Reply
Bookmarks