Sort column into rows of eight cells - excel

Question

I don't know if it's possible to do it,
I need to copy data from sheet 2 from column B with a variable range,
selecting 8 lines at a time from sheet 2,
pasting with transposition in sheet 1 starting from row 9 onwards? thank you
Sub copy()
Sheets(2).Range("B1:B8").Copy
With Sheets(1).Range("B9:I9")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheets(2).Range("B9:B16").Copy
With Sheets(1).Range("B10:I10")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheets(2).Range("B17:B24").Copy
With Sheets(1).Range("B11:I11")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheets(2).Range("B25:B32").Copy
With Sheets(1).Range("B12:I12")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Application.CutCopyMode = True
End Sub ```

Answer 1

The code assumes that the range we want to copy and paste is always the same and always 8 rows.
I assume the original data looks like this:
Then we can copy and transpose the range to this:
by using this code:
Sub Copy_paste_transpose()
Dim lrow_copy As Long
Dim i As Long, j As Long
Dim rows_to_copy As Long
lrow_copy = Sheets(2).Cells(Rows.Count, "B").End(xlUp).Row 'Find last row in Sheet2
i = 9 'Start pasting at row 9
rows_to_copy = 7 'always "remove" one row.
For j = 1 To lrow_copy Step 8 'Loop through range and "jump" 8 rows at each looping.
Sheets(2).Range(Sheets(2).Cells(j, "B"), Sheets(2).Cells(j + rows_to_copy, "B")).Copy 'Copy range
Sheets(1).Range(Sheets(1).Cells(i, 2), Sheets(1).Cells(i, 2 + rows_to_copy)).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Paste range and transpose the copied range
i = i + 1 'add one row after each paste
Next j
Application.CutCopyMode = False 'Deselect last copy selection
End Sub

Answer 2

Try this code:
Sub copy()
Const PERIOD = 8, PASTE_FROM_ROW = 9
Dim last_row As Long, i As Long
last_row = Sheets(2).Cells(Rows.Count, "B").End(xlUp).Row
For i = 0 To last_row \ PERIOD - 1
Sheets(1).Cells(PASTE_FROM_ROW + i, "B").Resize(, PERIOD) = _
WorksheetFunction.Transpose(Sheets(2).Cells(i * PERIOD + 1, "B").Resize(PERIOD))
Next
End Sub

Answer 3

Transpose a Column
Option Explicit
Sub TransposeColumn()
Const ProcName As String = "TransposeColumn"
On Error GoTo ClearError
Const sID As Variant = 2 ' or "Sheet2"
Const sFirst As String = "B1"
Const dID As Variant = 1 ' or "Sheet1"
Const dFirst As String = "B9"
Const dcCount As Long = 8
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source First Cell Range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sID)
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
' Using the 'GetTransposedColumn' function, write the transposed data
' to the Destination Array.
Dim dData As Variant: dData = GetTransposedColumn(sfCell, dcCount)
If IsEmpty(dData) Then Exit Sub
' Create a reference to the Destination First Cell Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dID)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
' Check if the values from the Destination Array fit
' into the Destination Worksheet.
Dim drCount As Long: drCount = UBound(dData, 1)
If drCount > dws.Rows.Count - dfCell.Row + 1 Then Exit Sub
If dcCount > dws.Columns.Count - dfCell.Column + 1 Then Exit Sub
' Create a reference to the Destination Range.
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
' Write the values from the Destination Array to the Destination Range.
drg.Value = dData
' Clear the contents below the Destination Range.
With drg
Dim crCount As Long: crCount = .Worksheet.Rows.Count - .Row + 1
If crCount > drCount Then
.Resize(crCount - drCount).Offset(drCount).ClearContents
End If
End With
MsgBox "Data transposed.", vbInformation, ProcName
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the transposed values of a one-column range
' in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetTransposedColumn( _
ByVal FirstCell As Range, _
Optional ByVal ColumnsCount As Long = 1) _
As Variant
Const ProcName As String = "GetTransposedColumn"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
If ColumnsCount < 1 Then Exit Function
Dim srg As Range
Dim srCount As Long
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
srCount = lCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
Dim sData As Variant
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
Dim dcrCount As Long: dcrCount = Int(srCount / ColumnsCount)
Dim dcRem As Long: dcRem = srCount Mod ColumnsCount
Dim drCount As Long
If dcRem = 0 Then
drCount = dcrCount
Else
drCount = dcrCount + 1
End If
Dim dData As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
Dim r As Long
Dim c As Long
Dim n As Long
If dcrCount > 0 Then
For r = 1 To dcrCount
For c = 1 To ColumnsCount
n = n + 1
dData(r, c) = sData(n, 1)
Next c
Next r
Else
r = 1
End If
If dcRem > 0 Then
For c = 1 To dcRem
n = n + 1
dData(r, c) = sData(n, 1)
Next c
End If
GetTransposedColumn = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function