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

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 ' 包含此代码的工作簿
    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 ' 无标题行
    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 用于标题行
    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 "分组堆叠完成。", vbInformation
End Sub