Copy / Paste Range of Cells Based on Cell Value

imagana

New Member
Joined
Apr 8, 2014
Messages
10
Hi, I need help figuring out a code that will do the following:

I am trying to copy a range of cells from sheet 2 to sheet 1 as many times as the number in cell A1 (in Sheet 2) indicates (the number in A1 will change on its own).

I would like to copy range of cells in sheet 2 starting in from cell B3 through the last cell with data (since the length of the range will vary) and paste it in Sheet 1 in column A in the next available blank cell.

Here is an example:
Sheet 2
A1: 3
B3: Cat
B4: Dog
B5: Banana


I would need Range("B3:B5") copied 3 times.

So Sheet 1 would look like the following:

A
Cat
Dog
Banana
Cat
Dog
Banana
Cat
Dog
Banana

I have this so far but it won’t paste all the cells in the range just the first cell of the range:


Sub CopyBasedOnCellValue()

Dim DataEntry As Worksheet, DataSht As Worksheet
Dim ItemName As range, ItemCount As range
Dim NRow As Long, TargetCell As range

With ThisWorkbook
Set DataEntry = .Sheets("Sheet 2")
Set DataSht = .Sheets("Sheet 1")
End With

With DataEntry
Set ItemName = .range("B3:B20")
Set ItemCount = .range("A1")
End With

With DataSht
NRow = .range("A" & Rows.count).End(xlUp).Row + 1
Set TargetCell = .range("A" & NRow)
TargetCell = ItemName.Value

End With

End Sub


Any help is greatly appreciate it!

Thank you so much!

Idalia
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Hi imagana, welcome to MrExcel Forum
This procedure should be copied to your standard code module 1.
Code:
Sub cpyMult()
Dim sh1 As Worksheet, sh2 As Worksheet, i As long, lr As Long, rng As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lr = sh2.Cells(RowsCount, 2).End(xlUp).Row
Set rng = sh2.Range("B3:B" & lr)
 For i = 1 To sh2.Range("A1").Value
  rng.Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
 Next
End Sub
The code is based on the narrative and illustration in the OP.
 

imagana

New Member
Joined
Apr 8, 2014
Messages
10
Thank You so much JLGWhiz for replying.

I tested the code two ways.. 1) added it to the code i originally posted and 2) on its own, (Please let me know if I did not do this correctly)

But oth times I got the following error:

Run-time error '1004'
Application-defined or object-defined error.

Since Im a little new to VBA, I do not know what this error means or how to fix it.
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
There is a typo on this line:
Code:
lr = sh2.Cells(RowsCount, 2).End(xlUp).Row

Should be
Code:
lr = sh2.Cells(Rows.Count, 2).End(xlUp).Row
 

imagana

New Member
Joined
Apr 8, 2014
Messages
10

ADVERTISEMENT

:biggrin: OMG! It works!!

:oops: One more thing i forgot to mention I think, the cells copied have formulas and I just want the values to be copied.

Again, Thank you so much! I really really appreciate!! (y)
 

imagana

New Member
Joined
Apr 8, 2014
Messages
10
Thank you so much JLGWhiz!!

I found a way to make it work, let me know what you think.

<Code>

Sub CopyMult()
Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, lr As Long, rng As range
Set sh1 = Sheets("Sensor Label")
Set sh2 = Sheets("AHU T1")
lr = sh2.Cells(Rows.count, 2).End(xlUp).Row
Set rng = sh2.range("B3:B" & lr)
For i = 1 To sh2.range("A1").Value
rng.Copy
sh1.Cells(Rows.count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
Next


<Code>
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Looks like you're home free.
Regards, JLG
 

Watch MrExcel Video

Forum statistics

Threads
1,123,312
Messages
5,600,887
Members
414,414
Latest member
neil_c

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