Copy & Paste certain range of cell multiple time

[SmartCookie]

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)

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:

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

 

[My Aswer Is This]

Try this:
Assuming we are copying from column B On sheet named: Silin
To column B on sheet named: Sheet1

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]

Try this:
Assuming we are copying from column B On sheet named: Silin
To column B on sheet named: Sheet1

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!!!

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