Copy, Paste, and Repeat Down Based on Adjacent Cell Value

[zljordan]

Hello all. I am fairly new to VBA, and have been stuck on this for a while now, and wondering if anyone might me able to help me out.

Is there a way to loop through a specific column, copying and pasting each cell X number of times (the value of X is in the adjacent column) to a new worksheet?

For example if in column C I have the string "Large Cap Core", and adjacent to it in Column B, there is the number 2, I would like to copy and paste the string "Large Cap Core", into a new worksheet 2x. If the number were 3, copy and paste 3x, and so on.

I have attached a sample workbook with the setup and desired results so you can get a better idea of what I am trying to accomplish. Any help or ideas that you have are greatly appreciated!

Thank you!

[mperrah]

try this

I didn't copy the blank rows but that can be changed.
I think this does what you're looking for

Sub vbax52573()
Dim c, i, x, lr, nr As Long

lr = Cells(Rows.Count, 3).End(xlUp).Row
nr = Sheets(2).Cells(Rows.Count, 3).End(xlUp).Row
    For x = 4 To lr
        c = Cells(x, 2).Value
        For i = 1 To c
            If Cells(x, 3).Value <> "" Then
            Cells(x, 3).Copy Destination:=Sheets(2).Cells(nr, 3)
            nr = nr + 1
            End If
        Next i
    Next x
End Sub

[zljordan]

This worked like a charm! Thank you so much.

[mperrah]

awesome sauce!

[Yongle]

An alternative
Try this on your sample file. Delete the values below the header in column C on sheet "Desired Results" and then run the macro.
NB - vba assumes that blank cells in column C contain nothing

(Value "THIS WILL BE DELETED LATER" put in the cells that end up blank and then deleted at end to make the LastRow calculation work)

Sub CopyPasteRepeat()

Dim LastRow, Repeat, NextRow, i, j, k

With Sheets("Setup")
    LastRow = .Range("C1000000").End(xlUp).Row

    For i = 4 To LastRow   'data begins in row 4
            NextRow = Sheets("Desired Results").Range("C1000000").End(xlUp).Row + 1
            If .Cells(i, 3) <> "" Then
                Repeat = .Cells(i, 2).Value
                .Cells(i, 3).Copy
                    For j = 1 To Repeat
                        Sheets("Desired Results").Cells(NextRow, 3).PasteSpecial xlAll
                        NextRow = NextRow + 1
                    Next j
            Else: Sheets("Desired Results").Cells(NextRow, 3).Value = "THIS WILL BE DELETED LATER"
            End If
    Next i
End With
    
With Sheets("Desired Results")
    LastRow = .Range("C1000000").End(xlUp).Row
    For k = 3 To LastRow
        If Cells(k, 3).Value = "THIS WILL BE DELETED LATER" Then
            Cells(k, 3).Value = ""
        End If
    Next k
End With

End Sub

[mperrah]

Thanks Yongle.
I had a few ideas to handle the blank rows but yours works nicely.
virtual knuckle bump

[srahul.ca]

I wish to copy the specific cells values from sheet1 to sheet2 and calculations will happen and copy again data from Sheet2 to sheet1

this process i wish to repeate for multiple line items in excel.

PLease help with VBA

An alternative
Try this on your sample file. Delete the values below the header in column C on sheet "Desired Results" and then run the macro.
NB - vba assumes that blank cells in column C contain nothing

(Value "THIS WILL BE DELETED LATER" put in the cells that end up blank and then deleted at end to make the LastRow calculation work)

Sub CopyPasteRepeat()

Dim LastRow, Repeat, NextRow, i, j, k

With Sheets("Setup")
    LastRow = .Range("C1000000").End(xlUp).Row

    For i = 4 To LastRow   'data begins in row 4
            NextRow = Sheets("Desired Results").Range("C1000000").End(xlUp).Row + 1
            If .Cells(i, 3) <> "" Then
                Repeat = .Cells(i, 2).Value
                .Cells(i, 3).Copy
                    For j = 1 To Repeat
                        Sheets("Desired Results").Cells(NextRow, 3).PasteSpecial xlAll
                        NextRow = NextRow + 1
                    Next j
            Else: Sheets("Desired Results").Cells(NextRow, 3).Value = "THIS WILL BE DELETED LATER"
            End If
    Next i
End With
    
With Sheets("Desired Results")
    LastRow = .Range("C1000000").End(xlUp).Row
    For k = 3 To LastRow
        If Cells(k, 3).Value = "THIS WILL BE DELETED LATER" Then
            Cells(k, 3).Value = ""
        End If
    Next k
End With

End Sub