Copy & Paste Multiples

tnemom

Board Regular
Joined
May 14, 2007
Messages
67
I have a worksheet that I have users enter data, and then that data is transfered to another sheet - so that the format can be used to create other things.

They enter the following data: Item, Type, Voltage, Activity and Quantity.

Right now I have the following code
Code:
Sub senddata()
Worksheets("QuesLinks").Select
 Range("A1:E1").Select
Application.CutCopyMode = False
Selection.Copy
Worksheets("Estimate List").Select
Dim LastCell As Range
With ActiveSheet
    Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
    If IsEmpty(LastCell) Then
         'do nothing
    Else
        Set LastCell = LastCell.Offset(1, 0)
        LastCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End If
End With


End Sub

What I was wondering is if the code can be altered so that based upon the quantity entered, data would be copied over in multiples.

If the quantity is one - the line is pasted once
If the quantity is two - the line is pasted twice...and so on.

Thanks
TNEMOM
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

venkat1926

Well-known Member
Joined
Aug 21, 2005
Messages
4,824
you have not said the number in which column should be taken into consideration for repeated copying. I assumed it is in column A. I have given headings as the first row.

if the relevant column is not column A you have to slightly modify the line
set col A=..............

run this macro and see sheet 2 whether you get what you want.

Code:
Sub test()


Dim colA As Range, c As Range
Dim dest As Range
Dim i As Integer, j As Integer
With Worksheets("sheet1")
Set colA = Range([a2], [a2].End(xlDown))
For Each c In colA
j = c
MsgBox j
Range(c, c.End(xlToRight)).Copy

With Worksheets("sheet2")
For i = 1 To j
Set dest = .Cells(Rows.Count, "a").End(xlUp).Offset(1, 0)
dest.PasteSpecial
Next i
End With
Next c
End With
application.cutcopymode=false
MsgBox "macro over"
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
57,412
Office Version
  1. 365
Platform
  1. Windows
tnemom

I am not certain that I have understood your requirements correctly, but give this a try. If it doesn't do what you want, explain in what way it fails and try to provide further details.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> senddata()
    <SPAN style="color:#00007F">Dim</SPAN> wsQL <SPAN style="color:#00007F">As</SPAN> Worksheet
    <SPAN style="color:#00007F">Dim</SPAN> wsEL <SPAN style="color:#00007F">As</SPAN> Worksheet
    <SPAN style="color:#00007F">Dim</SPAN> lrQL <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> crEL <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> Multiple <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    
    <SPAN style="color:#00007F">Set</SPAN> wsQL = Worksheets("QuesLinks")
    <SPAN style="color:#00007F">Set</SPAN> wsEL = Worksheets("Estimate List")
    wsEL.Range("A1:E1").Value = wsQL.Range("A1:E1").Value
    lrQL = wsQL.Range("A" & Rows.Count).End(xlUp).Row
    crEL = 2
    <SPAN style="color:#00007F">For</SPAN> r = 2 <SPAN style="color:#00007F">To</SPAN> lrQL
        Multiple = wsQL.Cells(r, 5).Value
        wsQL.Range("A" & r).Resize(, 5).Copy _
            Destination:=wsEL.Range("A" & crEL).Resize(Multiple)
        crEL = crEL + Multiple
    <SPAN style="color:#00007F">Next</SPAN> r
    Application.CutCopyMode = <SPAN style="color:#00007F">False</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 

tnemom

Board Regular
Joined
May 14, 2007
Messages
67
Here are screen shots of what I am trying to achieve.

This page is a list of questions the user will answer
senddata.xls
ABCD
1Whatitemwouldyouliketoaddfirst?
2Breaker
3
4WhatType?
5Oil
6
7Whatvoltage?
844KV
9
10WhatActivity?
11Remove/Replace
12
13Quantity?
142
Questions


These answers then get transfered to the "links" page
senddata.xls
ABCDE
1BreakerOil44KVRemove/Replace2
QuesLinks


Then the page that these links go to is the "Estimate List"
senddata.xls
ABCDEF
1WhatTypeVoltafeActionCode
2BreakerOil44KVRemove/ReplaceBR-O-44-RR
3BreakerOil44KVRemove/ReplaceBR-O-44-RR
Estimate List


Basically what I was trying to explain before was that when the user inputs the quantity of items they would like to perform work on, this quantity is then copied over to the "Estimate List" as per the examples presented.

They would like to Remove/Replace 2 44Kv Oil Breakers - so this line is then repeated twice on the Estimate List. If the quantity is 1 - then it is only copied once, quantity is 3 - then copied three times...and so on. The users then continue building the list for jobs to do in the estimate.

This Estimate List is then used to generate an estimate based on the information in it.

Hopefully I have cleared things up. I have tried the two code samples that were given, unfortunately due to my "clear as mud" explanation, they don't do what I wanted.

Thanks,
TNEMOM
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
57,412
Office Version
  1. 365
Platform
  1. Windows
OK, got a bit clearer idea now. Try the code below, noting that it does assume headings already appear in sheets "QuesLinks" and "Estimate List". I note that you don't have headings in "QuesLinks" but am guessing that you could put them in. If not ,and the code does not do what you want, post back.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> senddata()
    <SPAN style="color:#00007F">Dim</SPAN> wsQ <SPAN style="color:#00007F">As</SPAN> Worksheet
    <SPAN style="color:#00007F">Dim</SPAN> wsQL <SPAN style="color:#00007F">As</SPAN> Worksheet
    <SPAN style="color:#00007F">Dim</SPAN> wsEL <SPAN style="color:#00007F">As</SPAN> Worksheet
    <SPAN style="color:#00007F">Dim</SPAN> NextRowQL <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> NextRowEL <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> r <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> Multiple <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>
    
    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> wsQ = Worksheets("Questions")
    <SPAN style="color:#00007F">Set</SPAN> wsQL = Worksheets("QuesLinks")
    <SPAN style="color:#00007F">Set</SPAN> wsEL = Worksheets("Estimate List")
    NextRowQL = wsQL.Cells(Rows.Count, 1).End(xlUp).Row + 1
    NextRowEL = wsEL.Cells(Rows.Count, 1).End(xlUp).Row + 1
    <SPAN style="color:#00007F">For</SPAN> r = 1 <SPAN style="color:#00007F">To</SPAN> 5
        wsQL.Cells(NextRowQL, r).Value = wsQ.Cells(3 * r - 1, 1).Value
    <SPAN style="color:#00007F">Next</SPAN> r
    Multiple = wsQ.Cells(14, 1).Value
    wsQL.Cells(NextRowQL, 1).Resize(, 4).Copy _
            Destination:=wsEL.Cells(NextRowEL, 1).Resize(Multiple)
    Application.CutCopyMode = <SPAN style="color:#00007F">False</SPAN>
    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 

Forum statistics

Threads
1,181,658
Messages
5,931,271
Members
436,785
Latest member
KingGideon

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
Top