Sub doit()
dim x as double
Dim DataArray(100,3) as variant
Dim Fnd as double
Dim Z as double
Dim y as double
Dim OnRow as double

cells(1,1).select
x=1
do while true
if cells(x,1).value=empty then exit do
fnd=fnd+1
dataarray(fnd,1)=cells(x,1).value
dataarray(fnd,2)=cells(x,2).value
Dataarray(fnd,3)=cells(x,3).value
x=x+1
Loop

sheets("sheet2").select
OnRow=0
for x=1 to fnd
for Y=1 to Dataarray(x,2)
onrow=onrow+1
cells(onrow,1).value=dataarray(X,1)
cells(onrow,2).value=dataarray(x,2)
cells(onrow,3).value=dataarray(X,3)
next
Next
end sub


A B C
APPLES 18 4.95
PEARS 12 2.95

Thanks!