Try this code

```
Sub Test()
Dim a, b, i As Long, j As Long, k As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * 3, 1 To 3)
For i = 2 To UBound(a, 1)
For k = 2 To UBound(a, 2)
If a(i, k) <> "" Then
j = j + 1
b(j, 1) = a(1, k)
b(j, 2) = a(i, 1)
b(j, 3) = a(i, k)
End If
Next k
Next i
With Sheets("Sheet1").Range("I1")
.Resize(, UBound(b, 2)).Value = Array("Fruit", "Person", "Amount")
.Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
End With
End Sub
```

I have played around to make a public procedure for the code

You can try this code too

```
Sub Test_RowsMatrix()
With Worksheets("Sheet1")
RowsMatrix .Range("A1"), .Range("I1"), Array("Fruit", "Person", "Amount"), 3
End With
End Sub
Sub RowsMatrix(sourceCel As Range, tagretCel As Range, aHeaders As Variant, colNum As Long)
Dim a, b, i&, j&, k&, x&
a = sourceCel.CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * colNum, 1 To UBound(aHeaders) + 1)
For i = 2 To UBound(a, 1)
For k = 2 To UBound(a, 2)
If a(i, k) <> "" Then
j = j + 1
For x = 1 To colNum
b(j, x) = a(IIf(x = 1, 1, i), IIf(x = 2, 1, k))
Next x
End If
Next k
Next i
With tagretCel
.Resize(, UBound(b, 2)).Value = aHeaders
.Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
End With
End Sub
```