Copy row values from one worksheet to another in increments-CodePudding

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 "Workshet(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. The following is my code but it does not work. It copies the first record from A13 to A2 but then goes all awry. Please help!

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 frstRec As Long
    Dim k As Integer
    Dim SrcRowNo As Integer
    Dim DestRowNo As Integer
    Dim myRange As Range
    Set myRange = destws.Range("a2")
    'Source sheet starting row
    SrcRowNo = 13
    'Destination sheet starting row
    DestRowNo = 2
    'Copy and paste first record into destination sheet
    srcws.Cells(SrcRowNo, 1).Copy Destination:=destws.Cells(DestRowNo, 1)
    frstRec = myRange.Row
    For SrcRowNo = 13 To 50
        For frstRec = 2 To 50
            srcws.Cells(SrcRowNo   1, 1).Copy Destination:=destws.Cells(frstRec, 1)
        Next frstRec
    Next SrcRowNo
End Sub

CodePudding user response：

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.Cells(RowNo   13, 1).Copy Destination:=destws.Cells(RowNo*6   2, 1)
    Next RowNo
End Sub

CodePudding user response：

Option Explicit
Sub CopyData2()
    
    Dim wb As Workbook, wsSrc As Worksheet, wsDest As Worksheet
    Dim t0 As Single: t0 = Timer
    Set wb = ThisWorkbook
    Set wsSrc = wb.Worksheets("Equipment details")
    Set wsDest = wb.Worksheets("Worksheet (2)")
    
    ' copy A13->A2, A14->A8, A15->A14
    Const INCR = 6
    Const START_ROW = 13
    Const END_ROW = 1000
    Dim arSrc, arDest, i As Long, j As Long
    
    arSrc = wsSrc.Range("A" & START_ROW & ":A" & END_ROW).Value2
    arDest = wsDest.Range("A2:A" & INCR * UBound(arSrc)).Value2
    
    For i = 1 To UBound(arSrc)
        j = 1   (i - 1) * INCR
        arDest(j, 1) = arSrc(i, 1)
    Next
    wsDest.Range("A2").Resize(UBound(arDest)) = arDest
    MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub