Copy row values from one worksheet to another in increments

My question is of two parts:

Part 1:

I have two worksheets. In one worksheet named "Equipment details" I have a set of values in column A, rows 13 to 1000. I want to copy each of these values, namely A13, A14, A15 and so forth in to another worksheet named "Worksheet(2)" starting at cell A2. However, the trick is A13 from the first worksheet needs to be copied into A2 of the second worksheet, A14 to A8, A15 to A14 and so on in increments of 6 each time.

This part was sorted out earlier.

Part 2:

The new values copied over from "Equipment details" to "Worksheet(2)" now need to copy down their values to the next 6 rows and so on. For example, the Value in Cell A2 in "Worksheet(2)" needs to be copied down to rows A3 to A8. Then the next value in A9 that was copied over from "Equipment details" in Part 1 needs to be copied down from A10 to A15 and so on. This is my code and it works well in copying from Row A3 toA8 but then it does not jump to row A10 and instead keeps overwriting the values in rows A3 to A8.

Sub CopyDataInBetweenCells()
     Dim wb As Workbook
     Set wb = ThisWorkbook

     Dim destws As Worksheet
     Set destws = wb.Worksheets("Worksheet (2)")

     Dim RowNo2 As Long
     Dim RowNo3 As Long

     For RowNo2 = 1 To 2000
        For RowNo3 = 1 To 6
            destws.Cells(RowNo2 * 7 - 5, 1).Copy Destination:=destws.Cells(RowNo3 * 1   2, 1)
        Next RowNo3
     Next RowNo2
    
End Sub

CodePudding user response：

Use Resize

Sub CopyDataInBetweenCells()

     Dim wb As Workbook, destws As Worksheet
     Set destws = wb.Worksheets("Worksheet (2)")

     Dim RowNo As Long, n As Long
     With destws
        For n = 1 To 2000
            RowNo = 2   (n - 1) * 7
            .Cells(RowNo   1, 1).Resize(6) = .Cells(RowNo, 1)
        Next
     End With
End Sub

CodePudding user response：

Calculate the destination range:

Sub CopyData2()
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim srcws As Worksheet
    Set srcws = wb.Worksheets("Equipment details")
    Dim destws As Worksheet
    Set destws = wb.Worksheets("Worksheet (2)")
    Dim RowNo As Long

    For RowNo = 0 To 987
        srcws.Range("A" & RowNo   13).Copy Destination:=destws.Range("A" & RowNo * 7   2 & ":A" & RowNo * 7   8)
    Next RowNo

End Sub