Copy & Paste certain range of cell multiple time

SmartCookie

New Member
Joined
Feb 22, 2021
Messages
6
Office Version
  1. 2019
Platform
  1. Windows
Hello Friends,

I am trying to copy a range of data into a new sheet, but every single cell in this range need to repeat for four time. For example: (I have over 1000 cells in the original data)

1614731169095.png


The VBA code that I created loop through the original data selection, but couldn't copy to the right location, everytimes it overwritten the original data. See below:

VBA Code:
Sub Copy1()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim X As Integer
Dim Y As Integer

Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Silin")
Set ws2 = wb.Sheets("Sheet1")

LastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For X = 15 To 118
ws1.Cells(X, 2).Copy
ws2.Range(ws2.Cells(LastRow, 2), ws2.Cells(LastRow, 2).Offset(4, 0)).PasteSpecial
Application.CutCopyMode = False
Next X


End Sub

Any help or insight will be greatly appreciated!!

Thanks
Silin
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
17,555
Office Version
  1. 2013
Platform
  1. Windows
Try this:
Assuming we are copying from column B On sheet named: Silin
To column B on sheet named: Sheet1

VBA Code:
Sub Copy_My_Data()
'Modified  3/3/2021  12:46:11 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("Silin").Cells(Rows.Count, "B").End(xlUp).Row
Dim Lastrowb As Long
Lastrowb = 1

For i = 1 To Lastrow
    Sheets("Silin").Cells(i, 2).Copy Sheets("Sheet1").Cells(Lastrowb, 2).Resize(4)
    Lastrowb = Lastrowb + 4
Next
Application.ScreenUpdating = True
End Sub
 

SmartCookie

New Member
Joined
Feb 22, 2021
Messages
6
Office Version
  1. 2019
Platform
  1. Windows
Try this:
Assuming we are copying from column B On sheet named: Silin
To column B on sheet named: Sheet1

VBA Code:
Sub Copy_My_Data()
'Modified  3/3/2021  12:46:11 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Sheets("Silin").Cells(Rows.Count, "B").End(xlUp).Row
Dim Lastrowb As Long
Lastrowb = 1

For i = 1 To Lastrow
    Sheets("Silin").Cells(i, 2).Copy Sheets("Sheet1").Cells(Lastrowb, 2).Resize(4)
    Lastrowb = Lastrowb + 4
Next
Application.ScreenUpdating = True
End Sub
Hello,

Thank you so much!! It work, do you mind to explain a little on how this code work? specifically on this part, thank you!!!
VBA Code:
Application.ScreenUpdating = False
For i = 1 To Lastrow
    Sheets("Silin").Cells(i, 2).Copy Sheets("Sheet1").Cells(Lastrowb, 2).Resize(4)
    Lastrowb = Lastrowb + 4
Next
Application.ScreenUpdating = True
 

Watch MrExcel Video

Forum statistics

Threads
1,129,361
Messages
5,635,808
Members
416,884
Latest member
leeshjay

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