vba Paste data multiple times into another sheet

October 8, 2024

I’m tying to create a price list of our products to import into our system. My source data has the item code and base cost.

Desired output

I’m trying to use vba but my output only does the first entry. Below is the output I’m getting.

My code is below:

Sub PriceCopy()
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim Lastrows As Long, LastrowT As Long, i As Long
Dim ItemCode As String
Dim Price As Double
    
Set wsSource = ThisWorkbook.Worksheets("Sheet6")
Set wsTarget = ThisWorkbook.Worksheets("Sheet5")
    
Lastrows = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
FirstRow = 1

For i = 1 To Lastrows

ItemCode = wsSource.Range("A" & i).Value
Price = wsSource.Range("C" & i).Value

wsTarget.Range("A" & FirstRow).Value = ItemCode
wsTarget.Range("A" & FirstRow + 1).Value = ItemCode
wsTarget.Range("A" & FirstRow + 2).Value = ItemCode
wsTarget.Range("A" & FirstRow + 3).Value = ItemCode

wsTarget.Range("B" & FirstRow).Value = 1
wsTarget.Range("B" & FirstRow + 1).Value = 2
wsTarget.Range("B" & FirstRow + 2).Value = 3
wsTarget.Range("B" & FirstRow + 3).Value = 4

wsTarget.Range("C" & FirstRow).Value = Price + 1
wsTarget.Range("C" & FirstRow + 1).Value = Price + 1.1
wsTarget.Range("C" & FirstRow + 2).Value = Price + 1.2
wsTarget.Range("C" & FirstRow + 3).Value = Price + 1.3

LastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row

Next i
End Sub

Is it something in my For loop? Any help would be appreciated.

>Solution :

FirstRow refers to the row number where the output will be written. It should be incremented after each row is written.

Sub PriceCopy()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim Lastrows As Long, LastrowT As Long, i As Long
    Dim ItemCode As String
    Dim Price As Double
    Set wsSource = ThisWorkbook.Worksheets("Sheet6")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet5")
    ' get the first blank row on wsTarge col A
    If Len(wsTarget.Cells(1, "A"))=0 Then
        FirstRow = 1
    Else
        FirstRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
    End If
    ' get the last data row# of wsSource
    Lastrows = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrows
        ItemCode = wsSource.Range("A" & i).Value
        Price = wsSource.Range("C" & i).Value
        ' write Four item code all at once
        wsTarget.Range("A" & FirstRow).Resize(4,1).Value = ItemCode
        wsTarget.Range("B" & FirstRow).Value = 1
        wsTarget.Range("B" & FirstRow + 1).Value = 2
        wsTarget.Range("B" & FirstRow + 2).Value = 3
        wsTarget.Range("B" & FirstRow + 3).Value = 4
        wsTarget.Range("C" & FirstRow).Value = Price + 1
        wsTarget.Range("C" & FirstRow + 1).Value = Price + 1.1
        wsTarget.Range("C" & FirstRow + 2).Value = Price + 1.2
        wsTarget.Range("C" & FirstRow + 3).Value = Price + 1.3
        FirstRow = FirstRow + 4
    Next i
End Sub