Cut and paste dynamic ranges of data repeatedly - excel

Question

I am a PhD student and new to VBA.
I have been trying to automate sorting 1,8 million data points into a format suitable for data analysis. I am stuck. Would really appreciate anyone's help!
I need to automate the following:
Cutting a range of data in x sequential rows with identical Sequence numbers in column B.
And then paste it onto the right next to the previous range.
I found this code Excel VBA cut and paste rage repeatedly
Sub Cutrange()
Dim i As Long
Dim Lrow As Long
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim oRange As Range, dRange As Range
Set oRange = Range(Cells(1, 1), Cells(124, 14))
Set dRange = Cells(1, 1)
For i = 1 To Lrow
oRange.Offset(124 * i).Cut Destination:=dRange.Offset(, 14 * i)
Next i
End Sub
However, this code cuts and pastes a pre-determined range of cells (124x14). In my data, the number of rows (to be cut and pasted) needs to change based on how many rows have the same Sequence number.
Could anyone kindly help to change this code to fit my purpose or suggest alternative solutions?
Thank you,
Anna

Answer 1

HStack Groups of Data (VBA)
Option Explicit
Sub HStackGroups()
Const SRC_NAME As String = "Sheet1"
Const SRC_FIRST_CELL As String = "B2"
Const DST_NAME As String = "Sheet2"
Const DST_FIRST_CELL As String = "B2"
Const UNIQUE_COLUMN As Long = 1
Const COLUMN_GAP As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range(SRC_FIRST_CELL).CurrentRegion
Dim hData(): hData = srg.Rows(1).Value
Dim cCount As Long: cCount = srg.Columns.Count
Dim srCount As Long: srCount = srg.Rows.Count - 1 ' no headers
Dim sData(): sData = srg.Resize(srCount).Offset(1).Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim sr As Long, drCount As Long, srString As String
For sr = 1 To srCount
srString = CStr(sData(sr, UNIQUE_COLUMN))
If Not dict.Exists(srString) Then
Set dict(srString) = New Collection
End If
dict(srString).Add sr
If dict(srString).Count > drCount Then drCount = dict(srString).Count
Next sr
drCount = drCount + 1 ' 1 for headers
Dim dCount As Long: dCount = cCount + COLUMN_GAP
Dim dcCount As Long
dcCount = dict.Count * dCount - COLUMN_GAP
Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
Dim Coll, Item, sc As Long, d As Long, dr As Long, dc As Long
For Each Coll In dict.Items
dc = d * dCount
For sc = 1 To cCount
dData(1, dc + sc) = hData(1, sc)
Next sc
dr = 1
For Each Item In Coll
dr = dr + 1
For sc = 1 To cCount
dData(dr, dc + sc) = sData(Item, sc)
Next sc
Next Item
d = d + 1
Next Coll
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
With dfCell
.Resize(dws.Rows.Count - .Row + 1, dws.Columns.Count - .Column + 1) _
.Clear
End With
drg.Value = dData
drg.EntireColumn.AutoFit
MsgBox "Groups hstacked.", vbInformation
End Sub