Macro to copy/paste down X times (where X is the number of rows) [Solved/Closed]
JW328
Posts Friday January 4, 2013Registration date
February 21, 2013
Last seen
-
Feb 20, 2013 at 11:12 PM - Latest reply: TrowaD2356
Posts Sunday September 12, 2010Registration dateModeratorStatus
May 24, 2018
Last seen
- Jan 30, 2018 at 11:35 AM
OK so you want to copy down the values in column E and F down a variable number of times.
How will I know what the variable number is?
Or are columns A to D completely filled till say row 100 and columns E and F are only filled in row 2, 10, 55. And now you wish to copy E2:F2 and paste it to E3:F9 etc.?
Could you help me with a similar question...The difference for me is that I want to paste a specific amount of times (100).
So as of now I have,
If Application.WorksheetFunction.CountA("B:B") = 0 Then
[B1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
If Err <> 0 Then
On Error GoTo 0
[B65536].End(xlUp)(2, 1).Select
End If
On Error GoTo 0
End If
As per your sample data, the following code will do as requested.
The result will be placed in a second sheet. First sheet is called Sheet1 and the second sheet is called Sheet2. Either name your sheets like that or find those sheet references in the code and change them to match your (easily done by selecting entire code [CTRL+a] and use the find/replace window [CTRL+h]).
Here is the code:
Sub RunMe()
Dim x, lRow As Integer
lRow = Range("A" & Rows.Count).End(xlUp).Row
x = 1
Sheets("Sheet1").Select
With Sheets("Sheet2")
Do
x = x + 1
If Cells(x, "C").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "C").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "C").Value
End If
If Cells(x, "D").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "D").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "D").Value
End If
If Cells(x, "E").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "E").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "E").Value
End If
If Cells(x, "F").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "F").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "F").Value
End If
If Cells(x, "G").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "G").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "G").Value
End If
If Cells(x, "H").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "H").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "H").Value
End If
If Cells(x, "I").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "I").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "I").Value
End If
If Cells(x, "J").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "J").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "J").Value
End If
If Cells(x, "K").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "K").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "K").Value
End If
If Cells(x, "L").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "L").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "L").Value
End If
If Cells(x, "M").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "M").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "M").Value
End If
If Cells(x, "N").Value <> vbNullString Then
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "A")
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Sheets("Sheet1").Cells(x, "B")
.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(1, "N").Value
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = Cells(x, "N").Value
End If
Loop Until x = lRow
End With
End Sub
Best regards,
Trowa
Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.
Assuming your data is located in column A, then the following code will place the result in column B:
Sub RunMe()
Dim x, y As Integer
x = 1
For Each cell In Range("A1", Range("A1").End(xlDown))
For y = 1 To 80
Range("B" & x).Value = cell.Value
x = x + 1
Next y
Next cell
End Sub
I have try this code
Sub RunMe()
Dim x, y As Integer
x = 1
For Each cell In Range("A1", Range("A1").End(xlDown))
For y = 1 To 80
Range("B" & x).Value = cell.Value
x = x + 1
Next y
Next cell
End Sub
but this is not working if we have only 1 cell used in column, if we have used only one cell in column . ablove code not working fine I=, its got hang the sheet
It is always so hard to describe things. What was clear in my mind - is obviously not clear to another!
If I can get this to work - this macro will actually be in the middle of a much larger macro that actually works (except this one important step)!
Sheet 1 has data. What shows up on Sheet 1 is a result of some look ups. Not part of a Macro at all. It is dog information. Name and Owner (and a few other bits). So the user keys in a number and up pops all the information from the database about that dog. How many lines pop up could be 1 or any number up to about 250.
The Macro I have copies these lines to another sheet. Sheet 2. Sheet 2 will have columns A to G. And as I said - an undetermined number of lines. As many lines as there are records for the dog in the database.
Sheet 2 only has the lines copied from Sheet 1. Meaning there are no lines with spaces or blanks. Only the results from page 1 are on page 2. They get copied in by my Macro.
So now we are on sheet 2. Lets for my example say we copied in 11 rows.
I need the value in E1 and F1 to be copied down 10 times (11-1). So that all 11 rows have the same value in Column E and F.
The values in the other columns can not be change.
How many times do we have to copy? The same number of times as there are rows in sheet 2.
To illustrate. Below are the values in E and F only (example 4 rows)
Suzy John
Harry Max
Shevy Twinkle
Max Rover
The above is what came to sheet 2 via a copy.
I want the result to be:
Suzy John
Suzy John
Suzy John
Suzy John
Each time the Macro runs will have a different number of rows to copy down. And of course if there is only one row (which is possible!!) there is not need to copy anything as the correct information is in that row.
Good to tell this is part of a code.
I don't know on which sheet you are when this part of the code is activated, so I started out with referring to the correct sheet.
Second, when only 1 row exists nothing should be done. Normally I would exit sub, but now the code will skip the autofill part and continue with the code.
So just make sure the variable lRow isn't used before and/or is ok to be changed and this code is safe to implement as part of your code (of course without the Sub and End Sub parts).
Sub CopyValueDown()
Dim lRow As Integer
Sheets("Sheet 2").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
If lRow = 1 Then GoTo NextPartOfCode
Range("E1:F1").AutoFill Destination:=Range("E1:F" & lRow)
NextPartOfCode:
End Sub
Good luck with your code and let me know if more assistance is desired.
I have a very similar question. I am trying to do a sort of a burn. I need the cell value to be copied linearly across an x amount of rows, and the number or rows that it needs to be copied out lives in another table. How can this be done?
The code below will take the x amount of rows to be copied from Sheet2 cell A1.
Then takes the value from Sheet1 cell A1 and copies it down the amount found in Sheet2 cell A1.
Here is the code:
Sub RunMe()
Dim CopyX, x As Integer
CopyX = Sheets("Sheet2").Range("A1")
Sheets("Sheet1").Select
Range("A1").Copy
Do
x = x + 1
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
Loop Until x = CopyX
Application.CutCopyMode = False
End Sub
sravan-kr2
Posts Wednesday January 18, 2017Registration date
January 20, 2017
Last seen
>
TrowaD2356
Posts Sunday September 12, 2010Registration dateModeratorStatus
May 24, 2018
Last seen -Jan 18, 2017 at 09:17 AM
what if i want to do the same in columns please reply me as early as possible
"what if i want to do the same in columns please reply me as early as possible"
For that request try this:
Sub RunMe()
Dim CopyX, x As Integer
CopyX = Sheets("Sheet2").Range("A1")
Sheets("Sheet1").Select
Range("A1").Copy
Do
x = x + 1
Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial
Loop Until x = CopyX
Application.CutCopyMode = False
End Sub
The following code will keep the format of your input data.
Here it is:
Sub RunMe()
Dim x, y, z As Integer
x = Range("D" & Rows.Count).End(xlUp).Row
For y = x To 2 Step -1
z = Cells(y, "D").Value - 1
Do Until z = 0
Rows(y).Copy
Rows(y).Insert Shift:=xlDown
z = z - 1
Loop
Next y
Application.CutCopyMode = False
End Sub
jusip163
Posts Monday March 6, 2017Registration date
March 9, 2017
Last seen
>
TrowaD2356
Posts Sunday September 12, 2010Registration dateModeratorStatus
May 24, 2018
Last seen -Mar 9, 2017 at 10:41 PM
Hi Trowa,
Sure. Here is a sample data for 2015
l Code l Name l JAN l FEB l MAR l
l 145 l Socks l 20 l 74 l 52 l
l 992 l Bags l 52 l 102 l 278 l
I would like to change it to something like this
l Code l Name l Month l Amount
l 145 l Socks l JAN l 20
l 145 l Socks l FEB l 74
l 145 l Socks l MAR l 52
l 992 l Bags l JAN l 52
l 992 l Bags l FEB l 102
l 992 l Bags l MAR l 278
Assuming a second sheet is created with header.
In the code the source sheet is called: Sheet1.
And the destination sheet is called: Sheet2.
Here is the code:
Sub RunMe()
Dim mCol, mRow As Integer
Sheets("Sheet1").Select
For Each cell In Range("A2:A" & Range("A1").End(xlDown).Row)
mRow = cell.Row
mCol = 2
Do
mCol = mCol + 1
If Cells(mRow, mCol) <> vbNullString Then
Range(Cells(mRow, "A"), Cells(mRow, "B")).Copy _
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Cells(1, mCol).Copy Sheets("Sheet2").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
Cells(mRow, mCol).Copy Sheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
End If
Loop Until Cells(mRow, mCol) = vbNullString
Next cell
End Sub
Hi Trowa, I see you've helped some people already. I have a very similar task and hope you'll be able to help me as well.
I have a lot of unique rows in one column on tab "Pivot". For simplicity, let's take only three (A1:A3):
aaa
bbb
ccc
I need these values to repeat 14 times each one after the other on another tab "Results".
What code do I use? I used your initial code and modified it a bit:
Sub ToyNumber()
Dim toy, i As Integer
toy = 1
For Each cell In Range("A1", Range("A1").End(xlDown))
For y = 1 To 14
Range("B" & toy).Value = cell.Value
toy = toy + 1
Next i
Next cell
End Sub
I'm struggling how to get the output on a different tab (sheet). I'd appreciate your soonest assistance. Thank you.
Sub ToyNumber()
Dim toy, i As Integer
toy = 1
For Each cell In Range("A1", Range("A1").End(xlDown))
For i = 1 To 14
Range("B" & toy).Value = cell.Value
toy = toy + 1
Next i
Next cell
End Sub
In addition, I need values on sheet Results to start from cell A3, not A1, so that the first aaa will be in cell A3. I'm not sure how to modify this part: Range("B" & toy).Value = cell.Value.
Sub ToyNumber()
Dim toy, i As Integer
toy = 3 'changed 1 to 3, to start pasting from row 3.
For Each cell In Range("A1", Range("A1").End(xlDown))
For i = 1 To 14
Sheets("Result").Range("A" & toy).Value = cell.Value 'reference to the Result sheet added, also changed B to A.
toy = toy + 1
Next i
Next cell
End Sub
I am struggling with something similar to what has been described above.
I want to copy part of row (say A9:M9) and paste it down below (A10:M10, A11:M11 etc.) for the number of times specified by a cell value (e.g. the value of B4), which contains a row count function. Cells A9:M9 contain functions.
Hello! My issue is a combination of some others. I'm trying to have multiple columns copy/paste based on a number entered.
So, a user would enter number X into A2. I would then want to copy/paste columns E:H next to each other X number of times. This seems to be a combo of what annonyman and Sravan-kr asked, but I keep getting thrown in the Do statement.
Sub RunMe()
Dim x As Integer
x = Range("A2").Value
Do
Columns("E:H").Copy
Columns("E").Insert
x = x - 1
Loop Until x = 0
Application.CutCopyMode = False
End Sub
Looking to enter a name and then want it to be pasted in x number of rows. Then enter a new name in the x + 1 row and want that pasted y number of times and so on.
Is the entered name located in a cell or do you want Excel to ask you?
Is the x/y number of rows entered in a cell or do you want Excel to ask you?
Where do you want the names to be pasted?
Not sure if you are still stuck on this, but here is what I got for you:
Sub RunMe()
Dim x, xRep, lRow As Integer
lRow = Range("F" & Rows.Count).End(xlUp).Row
For x = lRow To 1 Step -1
xRep = Range("F" & x).Value
Do Until xRep = 1
With Rows(x)
.Copy
.Insert
End With
xRep = xRep - 1
Loop
Next x
Application.CutCopyMode = False
End Sub
Could you help me with a similar question...The difference for me is that I want to paste a specific amount of times (100).
So as of now I have,
If Application.WorksheetFunction.CountA("B:B") = 0 Then
[B1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
If Err <> 0 Then
On Error GoTo 0
[B65536].End(xlUp)(2, 1).Select
End If
On Error GoTo 0
End If
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=NOW()"
And I would like the formula to be pasted the same way overt the next 99 cells so I have 100 cells all in a row with the date and time.
To repeat the code you have until you reach row 100, you can add "Do" at the start and "Loop Until ActiveCell.Row = 100" at the end.
If this doesn't suffice then please explain your query in full detail.
Best regards,
Trowa