Range copy

kalim

Board Regular
Joined
Nov 17, 2010
Messages
87
Hi excel users.

What I need is to copy values from a cell down a range.
I have some sample data below (end result). To explain, F3 (DV cell) will be copied and the value is posted in the cells below, up to the last cell on the left. The same is true for the rest.
With the VBA code – I know it is poorly written with all the selects but I think it helps illustrate what I need and I tried to make it dynamic to adapt to all of the ranges I need it for.
It works as is, but (other than needing it to be written better of course)

1) It pastes over the original top cell which I don’t want it to – I will have a heading there. So F3 will then become the cell that is copied and etc for the rest.
2) And can it be done without having to reproduce it x amount of times. Case statement maybe?
Thanks.

<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Calibri,Arial; FONT-SIZE: 11pt" border=1 cellSpacing=0 cellPadding=0><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt; FONT-WEIGHT: bold"><TD></TD><TD>E</TD><TD>F</TD><TD>G</TD><TD>H</TD><TD>I</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">3</TD><TD></TD><TD>product 1</TD><TD></TD><TD></TD><TD>product 21</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">4</TD><TD style="TEXT-ALIGN: right">1</TD><TD>product 1</TD><TD></TD><TD style="TEXT-ALIGN: right">1</TD><TD>product 21</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">5</TD><TD style="TEXT-ALIGN: right">2</TD><TD>product 1</TD><TD></TD><TD style="TEXT-ALIGN: right">2</TD><TD>product 21</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">6</TD><TD style="TEXT-ALIGN: right">3</TD><TD>product 1</TD><TD></TD><TD style="TEXT-ALIGN: right">3</TD><TD>product 21</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">7</TD><TD></TD><TD></TD><TD></TD><TD style="TEXT-ALIGN: right">4</TD><TD>product 21</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">8</TD><TD></TD><TD>product 23</TD><TD></TD><TD style="TEXT-ALIGN: right">5</TD><TD>product 21</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">9</TD><TD style="TEXT-ALIGN: right">1</TD><TD>product 23</TD><TD></TD><TD></TD><TD></TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">10</TD><TD style="TEXT-ALIGN: right">2</TD><TD>product 23</TD><TD></TD><TD></TD><TD>product 3</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">11</TD><TD style="TEXT-ALIGN: right">3</TD><TD>product 23</TD><TD></TD><TD style="TEXT-ALIGN: right">1</TD><TD>product 3</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">12</TD><TD style="TEXT-ALIGN: right">4</TD><TD>product 23</TD><TD></TD><TD style="TEXT-ALIGN: right">1</TD><TD>product 3</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">13</TD><TD style="TEXT-ALIGN: right">5</TD><TD>product 23</TD><TD></TD><TD style="TEXT-ALIGN: right">3</TD><TD>product 3</TD></TR><TR style="HEIGHT: 22px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">14</TD><TD></TD><TD></TD><TD></TD><TD style="TEXT-ALIGN: right">4</TD><TD>product 3</TD></TR></TBODY></TABLE>

Excel tables to the web >> Excel Jeanie HTML 4


Code:
Sub copy1()
    Range("F3").Select
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
End Sub
 
Sub copy2()
    Range("F8").Select
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
End Sub
 
Sub copy3()
    Range("I3").Select
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
End Sub
 
Sub copy4()
    Range("I10").Select
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Hi Kalim,

Try with:

Code:
Sub Copy_values()
Dim P() As Integer

Pjts = WorksheetFunction.CountIf(Range("A:D"), "* *")
aA = "A1"
ReDim P(1 To Pjts, 2)

For i = 1 To Pjts
    aR = Cells.Find(What:="* *", After:=Range(aA), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Row
    aC = Cells.Find(What:="* *", After:=Range(aA), LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Column

aA = Cells(aR, aC).Address

P(i, 1) = aR: P(i, 2) = aC
Next

For j = LBound(P) To UBound(P)
    
    Count = Cells(P(j, 1) + 1, P(j, 2) - 1).End(xlDown).Row

    Cells(P(j, 1), P(j, 2)).Copy
    Range(Cells(P(j, 1) + 1, P(j, 2)), Cells(Count, P(j, 2))).PasteSpecial xlPasteAll
Next

End Sub
Regards
 
Upvote 0
Thanks for the reply.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
I am sorry cgcamal, but that code you provided me is far over my head. <o:p></o:p>
I tried your code but I can't get it to work properly. <o:p></o:p>
<o:p></o:p>
Does it attempt to copy all of the values at once? meaning product 1,23,21,3 will all get populated at once? If so, sorry that is not what I need to happen. Sorry if I did not make that clear.<o:p></o:p>
<o:p></o:p>
I only want one range to be copied at once. I.e. the user selects from the data validation cell in F2, F3 contains the heading now and the values will be pasted in cells f4:f6 in this case. So just this range will be pasted when the macro runs not all of them at once. <o:p></o:p>
<o:p></o:p>
The below I hope helps illustrate what I need. It does not work, but again I hope it helps illustrate what I need. <o:p></o:p>
<o:p></o:p>
Thanks.<o:p></o:p>
<o:p></o:p>

Code:
Sub copy()
 
Select Case Sheets("sheet1").Shapes("Rectangle")
 
Case Sheets("sheet1").Shapes("Rectangle 1") ' basically if rectangle 1 is clicked this only this part of the code will run etc.'
 
    Range("F2").Select
    Selection.Copy
    ActiveCell.Offset(2, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
 
Case Sheets("sheet1").Shapes("Rectangle 2")
 
    Range("F8").Select
    Selection.Copy
    ActiveCell.Offset(2, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
 
Case Sheets("sheet1").Shapes("Rectangle 3")
 
    Range("i2").Select
    Selection.Copy
    ActiveCell.Offset(2, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
 
Case Sheets("sheet1").Shapes("Rectangle 4")
 
    Range("i10").Select
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
 
   End Select
End Sub
 
Upvote 0
Does it attempt to copy all of the values at once? meaning product 1,23,21,3 will all get populated at once?
Yes kalim, it looks for all products and copy down until last cell in column to the left.

I only want one range to be copied at once. I.e. the user selects from the data validation cell in F2

But how do you now where product range has to be copy down?
Do you insert some key word in A1 or F1 or F2.. etc?
or you have 4 buttons to identify that when one of them is clicked?

Regards

 
Upvote 0
Would this be of any help to you? Refers only to the data in Cols E and F as in your example, but easily made more general as need be.
Code:
Sub fillins()
Dim e As Range
Set e = Range("E4")
Do While e.End(4).Row < Rows.Count
    Range(e, e.End(4)).Offset(, 1) = e(0).Offset(, 1)
    Set e = e.End(4).End(4)
Loop
End Sub
 
Upvote 0
But how do you now where product range has to be copy down?
Do you insert some key word in A1 or F1 or F2.. etc?
or you have 4 buttons to identify that when one of them is clicked?

Regards

Thanks again the replies, to answer your question cgcamal - I have 4 buttons that will be pushed by the user to identify which range needs to be copied. I.e. if the button "Rectangle 1" is clicked then only product 1 will be copied down in the appropriate cells. If "rectangle 2" button is clicked by the user then only product 23 will be copied down the appropriate cells etc.


mirabeau - thanks for the reply. I tried your code and it works well, but as stated above I need the ability for each individual range (4 in this case) to be copied independently, by the use of 4 buttons if possible.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
I am sorry if I have not explained my needs more clearly, hopefully they are clearer now.<o:p></o:p>
Thanks again for the help.<o:p></o:p>
 
Upvote 0
Hi Kalim,

Assuming your products are located in F2, F8, I3, I10 as table below,

Copy_products_on_click.jpg


then , try with this new code:

Before use it to work properly you need to:
1-) Create the 4 rectangles shapes and name them as Rectangle 1, Rectangle 2, Rectangle 3 and Rectangle 4.
2-) Create one rectangle shape named "Try again"
3-) Assign each shape to the macro below.
4-) Try it!

Code:
[COLOR=Navy]Sub[/COLOR] Copy_Products_On_Click()
[COLOR=Green]'César C. 13/May/2011[/COLOR]

Dim Rws as Integer, Cols as Integer, i as Integer, P as Integer, Sh As String

[COLOR=Green]'Setting up Rows and Columns numbers of main product("F2", "F8", "I2", "I10")[/COLOR]
Rws = Array(2, 8, 3, 10)
Cols = Array(6, 6, 9, 9)

Sh = ActiveSheet.Shapes(Application.Caller).Name

Select Case Sh
    Case "Rectangle 1"
        P = 0
        Count = Cells(Rws(P) + 1, Cols(P) - 1).End(xlDown).Row - Rws(P) + 1
        Cells(Rws(P), Cols(P)).Resize(Count, 1) = Cells(Rws(P), Cols(P))
    Case "Rectangle 2"
        P = 1
        Count = Cells(Rws(P) + 1, Cols(P) - 1).End(xlDown).Row - Rws(P) + 1
        Cells(Rws(P), Cols(P)).Resize(Count, 1) = Cells(Rws(P), Cols(P))
    Case "Rectangle 3"
        P = 2
        Count = Cells(Rws(P) + 1, Cols(P) - 1).End(xlDown).Row - Rws(P) + 1
        Cells(Rws(P), Cols(P)).Resize(Count, 1) = Cells(Rws(P), Cols(P))
    Case "Rectangle 4"
        P = 3
        Count = Cells(Rws(P) + 1, Cols(P) - 1).End(xlDown).Row - Rws(P) + 1
        x = Cells(Rws(P), Cols(P))
        Cells(Rws(P), Cols(P)).Resize(Count, 1) = Cells(Rws(P), Cols(P))
    Case "Try again"
        For i = 0 To 3
            Count = Cells(Rws(i) + 1, Cols(i) - 1).End(xlDown).Row - Rws(i)
            Cells(Rws(i) + 1, Cols(i)).Resize(Count, 1).ClearContents
        Next
End Select

[COLOR=Navy]End Sub[/COLOR]
Hope this helps

Regards
 
Last edited:
Upvote 0
Thanks again for the reply.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p> </o:p>
I followed you instructions to the letter, but the code stops and gives a compile error: expected array message. Rws is highlighted.<o:p></o:p>
 
Upvote 0
It is unclear if the target cells (eg F9:F13) are blank before the code is run.

If the target cells are blank before the code, then try the first code.

If the target cells are not blank (or may not be blank) then try the second code.

Test in a copy of your workbook and note that I have assumed the numbers in the left column of each section are constants, that is not the result of formulas.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> Fill_Values_1()<br>    <SPAN style="color:#00007F">Const</SPAN> HdrCell <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "F8" <SPAN style="color:#007F00">'<- Change to suit</SPAN><br>    <br>    <SPAN style="color:#00007F">With</SPAN> Range(HdrCell)<br>        Intersect(.CurrentRegion, .EntireColumn) _<br>            .SpecialCells(xlCellTypeBlanks).Value = .Value<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><br><SPAN style="color:#00007F">Sub</SPAN> Fill_Values_2()<br>    <SPAN style="color:#00007F">Const</SPAN> HdrCell <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "F8" <SPAN style="color:#007F00">'<- Change to suit</SPAN><br>    <br>    <SPAN style="color:#00007F">With</SPAN> Range(HdrCell)<br>        Intersect(.CurrentRegion, .Offset(, -1).EntireColumn) _<br>            .SpecialCells(xlCellTypeConstants).Offset(, 1) _<br>                .Value = .Value<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 
Last edited:
Upvote 0

Forum statistics

Threads
1,224,521
Messages
6,179,274
Members
452,902
Latest member
Knuddeluff

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top