Assuming that a worksheet #1 contains the data listed below, started from A1 cell:
ID Property Value
1234 Color Blue
1234 Width 1.5"
1234 Supplier XYX
1235 Color Orange
1235 Width 3.5"
1235 Supplier ZZA
and you want to achieve something like that (in a #2 worksheet):
ID Color Width Supplier
1234 Blue 1.5" XYX
1235 Orange 3.5" ZZA
below macro should do the job:
Option Explicit
Sub RowsToColumns()
Dim i As Integer, j As Integer, k As Integer
Dim srcWsh As Worksheet, dstWsh As Worksheet
On Error GoTo Err_RowsToColumns
Set srcWsh = ThisWorkbook.Worksheets(1)
Set dstWsh = ThisWorkbook.Worksheets(2)
dstWsh.Cells.Delete xlShiftUp
With dstWsh.Range("A1")
.Value = "ID"
.Font.Bold = True
.Interior.Color = vbGreen
End With
i = 2
j = 2
Do While srcWsh.Range("A" & i) <> ""
dstWsh.Range("A" & j) = srcWsh.Range("A" & i)
k = 0
Do While srcWsh.Range("A" & i + k) = srcWsh.Range("A" & i)
With dstWsh.Range("B1").Offset(ColumnOffset:=k)
.Value = srcWsh.Range("B" & i + k)
.Font.Bold = True
.Interior.Color = vbGreen
End With
dstWsh.Range("B" & j).Offset(ColumnOffset:=k) = srcWsh.Range("C" & i + k)
k = GetColumnNo(srcWsh.Range("B" & i + k), dstWsh)
Loop
i = i + k
j = j + 1
Loop
Exit_RowsToColumns:
On Error Resume Next
Set srcWsh = Nothing
Set dstWsh = Nothing
Exit Sub
Err_RowsToColumns:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_RowsToColumns
End Sub
Function GetColumnNo(sHeader As String, wsh As Worksheet) As Integer
Dim c As Integer
c = 0
Do While wsh.Range("A1").Offset(ColumnOffset:=c) <> ""
If wsh.Range("A1").Offset(ColumnOffset:=c) = sHeader Then Exit Do
c = c + 1
Loop
GetColumnNo = c
End Function
Note: the data and above macro should be in the same workbook.