Macro dejar constante y consecutivo

Necesito que al pegar en la columna 5, Cells(contador, 5) = Sheet1.Cells((Y - 2), j)
Se repita cuantas vences sea necesario según el contenido a pegar de las demás celdas.
El problema está en que solo pega la primera parte y no hace el consecutivo.
Agrego la macro:

Sub curvado2()

contador = 2
row_store = 5
Y = 5
articulos = Cells(2, 1) + 5

Do While Y < articulos

fila_curva = Application.WorksheetFunction.Match(Cells(Y, 9), Sheet2.Range("A1:BN1"), 0)
nro_curva = Application.WorksheetFunction.Count(Sheet2.Range(Sheet2.Cells(2, fila_curva), Sheet2.Cells(10000, fila_curva)))
nrodetiendas = Application.WorksheetFunction.CountA(Range("K3:FS3"))
For j = 11 To nrodetiendas + 10
For i = 1 To nro_curva
If Sheet1.Cells(Y, j) > 0 Then
If Sheet2.Cells(i + 1, fila_curva) > 0 Then
artic_code = Cells(Y, 1)
intro = Cells(Y, 10)
Descripcion = Cells(Y, 2)
Sheets(5).Select
Cells(contador, 1) = artic_code 'articcode
Cells(contador, 2) = intro 'fecha de intro
Cells(contador, 3) = Sheet2.Cells(i + 1, fila_curva) * Sheet1.Cells(Y, j)
Cells(contador, 4) = Sheet2.Cells(i + 1, fila_curva - 1) 'size
Cells(contador, 5) = Sheet1.Cells((Y - 2), j) ' ACA ESTA EL PROBLEMA
Cells(contador, 6) = Descripcion
contador = contador + 1
Sheets(1).Select
End If
End If

Next i
Next j
Y = Y + 1
Loop

End Sub