Public Function GetBlockRowCount2(ByVal textColRange As Range) As Long
    Dim vCount As Long, i As Long
    vCount = 1: i = 2
    Do Until textColRange.Cells(i, 1).IndentLevel = 0
        i = i + 1: vCount = vCount + 1
    Loop
    GetBlockRowCount2 = vCount
End Function

Public Sub CreateTransposed(ByVal dataSheet As Worksheet)
    Const dataRangeFirstCol = 1, dataRangeFirstRow = 2
    Dim dataRangeLastCol As Long, dataRangeLastRow As Long
    Dim dataLastRow As Long, dataLastCol As Long
    Dim iDataRow As Long, iDataCol As Long, t As Single
    Dim outRowCount As Long, outColCount As Long
    Dim blockRowCount As Long, lastBlockColId As Long
    Dim dataArr As Variant, outArr() As Variant
    Dim iCol As Long, iRow As Long, blockRange As Range
    t = Timer
    dataRangeLastRow = dataSheet.Cells(dataSheet.Rows.Count, dataRangeFirstCol).End(xlUp).Row
    Set blockRange = dataSheet.Range(dataSheet.Cells(dataRangeFirstRow, dataRangeFirstCol), _
                                    dataSheet.Cells(dataRangeLastRow, dataRangeFirstCol))
    blockRowCount = GetBlockRowCount2(blockRange)
    If (blockRange.Rows.Count Mod blockRowCount) > 0 Then
        MsgBox "Возможно блоки с переменным числом строк"
        Exit Sub
    End If
    dataRangeLastCol = dataSheet.Cells(dataRangeFirstRow, dataSheet.Columns.Count).End(xlToLeft).Column
    dataArr = blockRange.Resize(, dataRangeLastCol - dataRangeFirstCol + 1).Value
    dataLastRow = UBound(dataArr, 1): dataLastCol = UBound(dataArr, 2)
    outRowCount = dataLastRow \ blockRowCount: outColCount = blockRowCount + dataLastCol - 1
    lastBlockColId = blockRowCount - 1
    ReDim outArr(0 To outRowCount - 1, 0 To outColCount - 1)
    For iDataRow = 1 To dataLastRow
        iRow = (iDataRow - 1) \ blockRowCount: iCol = (iDataRow - 1) Mod blockRowCount
        outArr(iRow, iCol) = dataArr(iDataRow, 1)
        If iCol = lastBlockColId Then
            For iDataCol = 2 To dataLastCol
                outArr(iRow, iCol + iDataCol - 1) = dataArr(iDataRow, iDataCol)
            Next
        End If
    Next
    dataSheet.Parent.Worksheets.Add.Range("A1").Resize(outRowCount, outColCount).Value = outArr
    MsgBox Timer - t
End Sub