ns.Cells(CInt(hr) + 1, 1).Resize(UBound(out(), 1), UBound(out(), 2)) = out()

Sub Redesigner()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim inpdata As Range, realdata As Range, ns As Worksheet
    Dim i&, j&, K&, c&, R&
    Dim hc As Variant, hr As Variant
    Dim out(), dataArr, hcArr, hrArr
    Dim i1 As Long, i2 As Long
    
    Set inpdata = Selection
    
    'оставляемые строки сверху
    hr = InputBox("Сколько строк с подписями сверху (равносильно - сколько уровней в шапке над значениями)?")
    
    If hr = Cancel Then GoTo e_end
    If Not (IsNumeric(hr)) Then
        y = MsgBox("Введенное значение не является числом")
        GoTo e_end
    End If

    'оставляемые столбцы слева
    hc = InputBox("Сколько столбцов с подписями слева?")
    
    If hc = Cancel Then GoTo e_end
    If Not (IsNumeric(hc)) Then
        y = MsgBox("Введенное значение не является числом")
        GoTo e_end
    End If

    'проверка по совпадениям с изначальным диапазоном
    If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then
        y = MsgBox("Одно из введенных значений превышает границы изначального диапазона")
        GoTo e_end
    End If
    
    'преобразование данных
    Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc)
    dataArr = realdata.value
    If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).value
    If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).value
    
    ReDim out(1 To Application.CountA(realdata), 1 To hr + hc + 1)
    Set ns = Worksheets.Add
    
    For i = 1 To UBound(dataArr, 1)
        For j = 1 To UBound(dataArr, 2)
            If Not IsEmpty(dataArr(i, j)) Then
                K = K + 1
                For c = 1 To hc: out(K, c) = hcArr(i, c): Next c
                For R = 1 To hr: out(K, c + R - 1) = hrArr(R, j): Next R
                out(K, c + R - 1) = dataArr(i, j)
            End If
    Next j, i
    
    'добавлениеданных на новый лист
    'ns.Cells(2, 1).Resize(UBound(out, 1), UBound(out, 2)) = out
    ns.Cells(hr + 1, 1).Resize(UBound(out, 1), UBound(out, 2)) = out
    
    'Заголовки слева
    For i1 = 1 To hr
        For i2 = 1 To hc
            ns.Cells(i1, i2) = inpdata(i1, i2)
        Next i2
    Next i1
    
    'Заголовки преобразованных столбцов
    If hr = 1 Then ns.Cells(hr, hc + 1) = "Столбцы"
    If hr > 1 Then
        For i1 = 1 To hr
            ns.Cells(hr, hc + i1) = "Столбцы_" & CStr(i1)
        Next i1
    End If

    'Заголовки значений
    ns.Cells(hr, CInt(hc) + CInt(hr) + 1) = "Значения"
    
    'Выделение заголовков
    ns.Cells(1, 1).Resize(hr, CInt(hc) + CInt(hr) + 1).Font.Bold = True
    ns.Cells(1, 1).Resize(hr, CInt(hc) + CInt(hr) + 1).Interior.Color = RGB(217, 217, 217)

e_end:

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub