Option Explicit
Type RecType
PartNo As String
Price() As String
End Type
Sub ElimateDups()
Dim WksDest As Worksheet
Dim RowNo As Long
Dim ColNo As Long
Dim rngSrc As Range
Dim rec() As RecType
Dim Idx As Long
Dim J As Integer
ReDim rec(0)
ReDim rec(0).Price(0)
Set rngSrc = ThisWorkbook.Worksheets("Sheet1").UsedRange
Set WksDest = ThisWorkbook.Worksheets("Sheet2")
WksDest.Cells.ClearContents
RowNo = 2
Do While RowNo <= rngSrc.Rows.Count
Debug.Print rngSrc.Cells(RowNo, 1)
Idx = InsertRec(Trim(rngSrc.Cells(RowNo, 1)), Trim(rngSrc.Cells(RowNo, 2)), rec)
RowNo = RowNo + 1
' 'Now Export the data to a second workshhet
For Idx = 1 To UBound(rec)
WksDest.Cells(Idx, 1) = rec(Idx).PartNo
For J = 0 To UBound(rec(Idx).Price)
WksDest.Cells(Idx, 2 + J) = rec(Idx).Price(J)
Next J
Next Idx
Loop
End Sub
Function InsertRec(ByVal PartNo As String, ByVal Price As String, rec() As RecType) As Long
Dim Idx As Long
Dim intUB As Integer
For Idx = 0 To UBound(rec)
If rec(Idx).PartNo = PartNo Then
Exit For
End If
Next Idx
If Idx > UBound(rec) Then
ReDim Preserve rec(Idx)
rec(Idx).PartNo = PartNo
ReDim rec(Idx).Price(0)
rec(Idx).Price(0) = Price
Else
intUB = UBound(rec(Idx).Price) + 1
ReDim Preserve rec(Idx).Price(intUB)
rec(Idx).Price(intUB) = Price
End If
End Function