I have some data that takes up 4 columns and 1400 rows. Every 15th row corresponds to a different city, which is named in column A. For example, rows 1-14 might be Tokyo, but rows 15-28 Toronto. For now, we can ignore column A. Is there any way to automatically copy and paste each remaining 14 row and 3 column block such that they will all appear side-by-side?

My ultimate goal is to put a header row of merged cells made from column A above each 14 by 3 block in order to give them a title. However, I must first extract the required 14 by 3 blocks. I presume that this is the job for a VBA macro?

For example, part of my data looks like this:

[...12 more Toronto rows]

etc

My best attempt so far was to take this raw data and reference it on another sheet with =RAW!$B1:$D14 and drag that formula down through the hundreds of rows, copy the result, and then transpose it. This gave me the correct output, but each 14 by 3 block was separated by a 11 by 14 block of empty cells. I wanted them side-by-side.

CodePudding user response：

Please, test the next code. It uses arrays and their slice arrays and returns in the next sheet. You can choose any destination sheet you need. If you test it as it is, you must be sure that another sheet exists after the active one (to be processed) and it is empty:

Sub CopySlicesOf15()
  Dim sh As Worksheet, shDest As Worksheet, lastR As Long, arr, arrSlice, arrH, arrA
  Dim cellInit As Range, iPaste As Long, lastArrR As Long, i As Long, k As Long
  
  Set sh = ActiveSheet  'use here the sheet to be processed
  Set shDest = sh.Next  'use here the sheet where to return the processed result
  Set cellInit = shDest.Range("A2")     'the cell where to start pasting the slice arrays from
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'you use 1400 instead if you like that...
  arrA = sh.Range("A1:A" & lastR).value 'place the range in an array for faster iteration
  arr = sh.Range("B1:D" & lastR).value  'place the rang in an aray, for faster iteration and slicijg
  ReDim arrH(Int(lastR / 15)   1)       'redim the array keeping the future headers
  For i = 1 To UBound(arr) Step 15      'iterate between the main array in steps of 15 rows:
        arrH(k) = arrA(i, 1): k = k   1 'place the appropriate header in the headers array
        If i > (UBound(arr) - 15) Then
            lastArrR = i   (UBound(arr) - i)  'the slice numbere of rows for the last slice
        Else
            lastArrR = i   14                 'until the last slice, the slice numbere of rows will be 15
        End If
        'extract the necessary slice array:
        arrSlice = Application.Index(arr, Evaluate("row(" & i & ":" & lastArrR & ")"), Evaluate("column(A:C)"))
        'drop the array content at once in the appropriate cells:
        shDest.Range("A2").Offset(0, iPaste).Resize(IIf(UBound(arr) = i, 1, UBound(arrSlice)), 3).value = arrSlice: iPaste = iPaste   3
  Next i
  
  iPaste = 1                                  'reinitialize the variable
  For i = 1 To UBound(arrH)                   'iterate between the headers array
    shDest.cells(1, iPaste).value = arrH(i)   'place the header name in the cell
    'merge cells and center:
    With shDest.Range(shDest.cells(1, iPaste), shDest.cells(1, iPaste).Offset(0, 2))
        .merge
        .HorizontalAlignment = xlCenter
    End With
    iPaste = iPaste   3 ' increment the variable for next cell to paste the header
  Next
End Sub