Copy/Paste Rows based on value in cell

[K1600]

Hi,

I am trying to write some VBA code to paste data from cells A4:J4 into the rows below based on a cell value in cell P3. Basically if cell P3 is 5 then I want to copy A4:J4 and paste it 5 times (the number from P3) starting at cell A5, if P3 is 25 then paste 25 times and so on.

I only want it to do the copy/paste if cell P3 is greater than 0. All of this is happening in "Sheet1".

I've viewed many posts from others doing similar things but I can't seem to get it to work. I would be most grateful if someone could assist.


Thanks in advance.

Glynn

 

[StephenCrump]

What code do you have so far?

 

[mrshl9898]

How's this?

Sub copybasedoncell()

Dim rownum As Long
Dim copycount As Long
Dim x as long


copycount = Sheets("Sheet1").Range("P3").Value
Sheets("Sheet1").Range("A4:J4").Copy


x = 0
rownum = 5


Do Until x = copycount


Sheets("Sheet1").Cells(rownum, 1).PasteSpecial xlPasteAll
x = x + 1
rownum = rownum + 1


Loop


End Sub

 

[K1600]

Nothing really that is working.

I have this initially which is setting up row 4 if P3 is >0 which is working fine. Just for info, if P3 is not >0 then there is no requirement for anything to happen.

Private Sub CmdTest_Click()
Dim wbk As Workbook
Set wbk = Workbooks.Open("\\GLYNN-LAPTOP\Admin Dashboard.xlsm", ReadOnly:=True)


If wbk.Sheets("Sheet1").Range("P3") > "0" Then
            Range("A4").Value = "=EDATE(A3,1)"
            Range("B3:J3").Copy
            Range("B4:J4").PasteSpecial
        ElseIf wbk.Sheets("Sheet1").Range("P3") = "0" Then
        Exit Sub
        End If
End Sub

After that I'm struggling, I'm currently playing with the following two but not getting very far both I have found through trawling the net:

Dim rng As Range
Dim r As Range
Dim numberOfCopies As Integer
Dim n As Integer


'## Define a range to represent ALL the data
Set rng = Range("A4", Range("J4").End(xlDown))


'## Iterate each row in that data range
For Each r In rng.Rows
    '## Get the number of copies specified in column 14 ("N")
    numberOfCopies = r.Cells("P3").Value


'    '## If that number > 1 then make copies on a new sheet
    If numberOfCopies > 1 Then
'        '## Add a new sheet
'        With Sheets.Add
            '## copy the row and paste repeatedly in this loop
            For n = 1 To numberOfCopies
                r.Copy .Range("A5" & n)
            Next
'        End With
    End If
Next

and

Dim rangeInventory As Range
Dim rangeSingleCell As Range
Dim numberOfRepeats As Integer
Dim n As Integer
Dim lastRow As Long


'Set rangeInventory to all of the Inventory Data
Set rangeInventory = Sheets("Sheet1").Range("A4", Sheets("Sheet1").Range("J4").End(xlDown))


'Iterate each row of the Inventory Data
For Each rangeSingleCell In rangeInventory.Rows
    'number of times to be repeated copied from Sheet1 column 4 ("C")
    numberOfRepeats = rangeSingleCell.Cells(1, 16).Value '


    'check if numberOfRepeats is greater than 0
    If numberOfRepeats > 0 Then
         With Sheets("Sheet2")
            'copy each invetory item in Sheet1 and paste "numberOfRepeat" times in Sheet2


                For n = 1 To numberOfRepeats
                lastRow = Sheets("Sheet1").Range("A1048576").End(xlUp).Row
                r.Copy
                Sheets("Sheet1").Range("A" & lastRow + 1).PasteSpecial xlPasteValues
            Next
        End With
    End If
Next

Thanks

 

[K1600]

Star man,

Exactly what I needed. Thank you so much!


Glynn

 

[StephenCrump]

If P3 is negative, this loop might run for a while!

copycount = Sheets("Sheet1").Range("P3").Value
x = 0
Do Until x = copycount
    x = x + 1
Loop

An alternative without looping:

With Worksheets("Sheet1")
    copycount = .Range("P3").Value
    If copycount > 0 Then .Range("A5:J" & .Range("P3").Value + 4).Value = Range("A4:J4").Value
End With

 

[K1600]

Cheers StephenCrump,

I will amend it to prevent it looping as there is a good possibility that it could be P3 is negative.


Cheers,

Glynn

 

[K1600]

As an extra thought, once it has completed the copy/paste the original selection, A4:J4 is still selected with 'I've been copied' type box around it.

Any idea how I can stop this? I have added an extra line to select A1 to see if that stops it but no such luck.


Thanks in advance, Glynn

 

[StephenCrump]

I will amend it to prevent it looping as there is a good possibility that it could be P3 is negative.

You could rewrite the loop so that if P3 is zero or negative, it doesn't iterate:

copycount = Sheets("Sheet1").Range("P3").Value

For x = 1 To copycount
    'Paste
Next x

A4:J4 is still selected with 'I've been copied' type box around it.

After the copy/paste, you need:

Application.CutCopyMode = False