Copy data while shifting the row range

Question

I am trying to copy data into another sheet. The rows needs to be copied every 7 rows. This is the code I have. The columns will remain static.

The code copies the data but it is copying only the 7th row. It is skipping all the other rows. But what I want is to shift the range every 7th row. I want it to shift the copying data every time it is copying. That is it will copy 7 row the first time, then it will copy the next 7 row, and so on.

Can you please help?

Sub Copydata()
'
' Transpose the data Macro
'

'
    Dim Cellidx As Range
    Dim NextRow As Long
    Dim rng As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim srcWks As Worksheet
    Dim DataWks As Worksheet
    Dim row As Range
    Dim cell As Range
    Dim i As Long, lr As Long, lr2 As Long
    Dim j As Long
    Dim iLastRow As Integer
    Dim xRow As Long
    Dim lastrow As Long
    Dim lColumn As Long
    Dim Lrow As Long
    Dim iRowOffset1 As Integer
    Dim iRowOffset2 As Integer
    
    Set srcWks = Worksheets("EQ")
    Sheets.Add.Name = "Datasheet"
    Set DataWks = Worksheets("Datasheet")
    Set rng = srcWks.Range("B9:J15")
    Set rng2 = srcWks.Range("B9:J3424")
    
    'lr = srcWks.Range("A" & Rows.Count).End(xlUp).row
    
    myarray = Range("B9:J15")
    
    NextRow = DataWks.UsedRange.Rows.Count
    Set row = Range(Cells(NextRow, 9), Cells(NextRow, 7))
    
    'Nextow = IIf(NextRow = 1, 1, NextRow + 1)
    lastrow = srcWks.Cells(srcWks.Rows.Count, 1).End(xlUp).row
    lColumn = DataWks.Cells(1, DataWks.Columns.Count).End(xlToLeft).Column
    
    ' Find next available row on destination sheet
    Lrow = Worksheets("Datasheet").Range("A" & Rows.Count).End(xlUp).row + 1
    
    'LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
    'srcWks.Range(StartCell, srcWks.Cells(LastRow, LastColumn)).Select
    
    srcWks.Select
    Range("A2:J8").Select
    Selection.Copy
    DataWks.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    'For Each row In rng2.Rows
    'For Each row In rng2
        'For Each cell In row.Cells
    srcWks.Select
    iRowOffset1 = 0
    iRowOffset2 = 0
    For i = 2 To lastrow
            
        'For j = 1 To lColumn
        
            'For Each rng In rng2
        Application.CutCopyMode = False
                'Range((srcWks.Cells(i, 1)), srcWks.Cells(i, srcWks.Columns.Count).End(xlToLeft)).Copy
            'rng3.Cells(r, c).Value.Select
        rng.Offset(iRowOffset2, 0).Copy
                'rng3.Copy
            
                
            'Selection.COPY
        DataWks.Select
            'DataWks.Cells(Lrow, "A").Select
        Range("A11").Select
        Selection.Offset(iRowOffset1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        iRowOffset2 = iRowOffset2 + 7
        iRowOffset1 = iRowOffset1 + 1
            'ActiveCell.Offset(1, 0).End(xlDown).Select
            'ActiveCell.Offset(1, 0).Select
            'Range(ActiveCell, ActiveCell.Offset(0, x)).Select
            'Next rng
        'Next j
            
    Next i
        
    End Sub

Answer 1

I have done two things:

• I've replaced "whatever.Select, Selection.DoSomething" by "whatever.DoSomething"
• I've added an offset, to that you don't always copy to the same cell "A11" in your destination sheet:

Sub Copydata()

Dim Cellidx As Range
Dim NextRow As Long
Dim rng As Range
Dim rng2 As Range
Dim srcWks As Worksheet
Dim DataWks As Worksheet
Dim row As Range
Dim cell As Range
Dim i As Long, lr As Long, lr2 As Long
Dim iLastRow As Integer
Dim iRowOffset As Integer

  Set srcWks = Worksheets("EQR")
  Sheets.Add.Name = "Datasheet"
  Set DataWks = Worksheets("Datasheet")
  Set rng = srcWks.Range("B9:J15")
  Set rng2 = srcWks.Range("B9:J3424")
  'lr = srcWks.Range("A" & Rows.Count).End(xlUp).row
  NextRow = DataWks.UsedRange.Rows.Count
  Set row = Range(Cells(NextRow, 9), Cells(NextRow, 7))
  'Nextow = IIf(NextRow = 1, 1, NextRow + 1)
  'iLastRow = Cells(Rows.Count, "a").End(xlUp).row
  LastRow = srcWrks.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
  'LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
  'srcWks.Range(StartCell, srcWks.Cells(LastRow, LastColumn)).Select
  srcWks.Range("A2:J8").copy
  DataWks.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=True
  'For Each row In rng2.Rows
  iRowOffset = 0
  For Each row In rng2
      'For Each cell In row.Cells
      Application.CutCopyMode = False
      srcWks.rng.copy
      Sheets("Datasheet").Range("A11").Offset(iRowOffset,0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=True
      NextRow = NextRow - 1
      iRowOffset = iRowOffset + 1 ' Instead of always pasting to cell A11, go to the next row
  Next row
End Sub