Option Explicit
Sub Redesigner_V2()
' Данное решение построено на массивах, авторство принадлежит МСН (http://www.excelworld.ru).
' Внес небольшую коррективу, а именно запрос на выделение диапазона - Максим Зеленский, с дружеского форума (http://www.planetaexcel.ru).
' Дополнительные улучшения и полезности - SLAVICK (http://www.excelworld.ru)
' Небольшие дополнения и коррективы - DJ Marker MC (http://www.excelworld.ru).
            
        Dim inpdata As Range, realdata As Range, ns As Worksheet
        Dim i&, ii&, c&, r&, hc&, hr&, nSt&, nT&
        Dim out(), dataArr(), hcArr(), hrArr(), shapka ', shapkaFirst As Boolean
        On Error GoTo line1
            
            Set inpdata = Application.InputBox("Выберите обрабатываемый диапазон:", "Выбор диапазона", Selection.Address, Type:=8)
            hr = InputBox("Сколько строк с подписями данных сверху", , 1)
            hc = InputBox("Сколько столбцов с подписями данных слева?", , 1)
            nSt = InputBox("Сколько столбцов с данными будет в правой части таблицы? (например: если Ваша таблица уходит вправо на 24 месяца то указав тут 12 - месяцы разобьются по столбцам, а год перенесется по строкам", , 1)
'    Проверка шапки если  nSt = 1
        If nSt = 1 And hr > 1 Then
                If MsgBox("Выбрано только один столбец повторения, уменьшить шапку?", vbYesNo) = vbYes Then
                shapka = inpdata.Cells(hr, 1).Resize(1, hc).Value 'realdata.Value
                Else
                shapka = inpdata.Resize(hr, hc).Value 'realdata.Value
                End If
            Else
            shapka = inpdata.Resize(hr, hc).Value 'realdata.Value
        End If
            
        Application.ScreenUpdating = False
        If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub
        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
            
'    Проверка шапки
        For i = 1 To UBound(hrArr)
        For ii = 1 To UBound(hrArr, 2)
            hrArr(i, ii) = Проверка_слова(CStr(hrArr(i, ii)))
        Next ii, i
'    Проверка справочника
        For i = 1 To UBound(hcArr)
        For ii = 1 To UBound(hcArr, 2)
            hcArr(i, ii) = Проверка_слова(CStr(hcArr(i, ii)))
        Next ii, i
'====================================
        ReDim out(1 To realdata.Count / nSt, 1 To hr + hc + nSt)
'Начало основного цикла
        hr = 0
        For i = 1 To UBound(hcArr)
                hc = 1
                For ii = 1 To Int(UBound(dataArr, 2) / nSt)
                hr = hr + 1
                    For r = 1 To UBound(hrArr): out(hr, r) = hrArr(r, hc): Next r
                    For c = 1 To UBound(hcArr, 2): out(hr, c + r - 1) = hcArr(i, c): Next c
                    For nT = 1 To nSt
                        '   Добавление данных если не ошибка
                        If Not IsError(dataArr(i, hc)) Then out(hr, c + r + nT - 2) = dataArr(i, hc)
                        hc = hc + 1
                    Next
                Next
        Next
        Set ns = Worksheets.Add '   Добавление листа
            
            If IsArrayEmpty(shapka) = False Then
                ns.Cells(1, r).Resize(UBound(shapka), UBound(shapka, 2)) = shapka
                If nSt = 1 Then ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = "Значения" Else ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = hrArr '    Выгрузка шапки столбцов
                r = UBound(shapka) + 1
            Else
                ns.Cells(1, r) = shapka '    Выгрузка шапки строк
                If nSt = 1 Then ns.Cells(1, r + c - 1) = "Значения" Else ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr '    Выгрузка шапки столбцов
                r = 2
            End If
            ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out '  Выгрузка данных
        'Удобности:
            ns.Cells(1, 1).Resize(r - 1, UBound(out, 2)).Interior.ColorIndex = 44 ' Закрашивание шапки
            ns.Cells(r, UBound(hrArr) + c).Select: ActiveWindow.FreezePanes = True '    Закрепление шапки
            ns.Range(Cells(r - 1, 1), Cells(UBound(out), UBound(out, 2))).AutoFilter '  Установка Автофильтра
' Установка границ
        With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2))).Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
Application.ScreenUpdating = True
line1:
End Sub
Private Function Проверка_слова(str As String)
        If Len(str) = 1 Then Проверка_слова = str: Exit Function
        If IsError(str) = True Then Проверка_слова = "": Exit Function
        If Not IsDate(str) And Not IsNumeric(str) Then Проверка_слова = str: Exit Function
        If Left(str, 2) = "0," Then Проверка_слова = str * 1: Exit Function
        If Left(str, 1) = "0" Then Проверка_слова = "'" & str: Exit Function
        If InStr(1, str, "-") > 0 Then Проверка_слова = "'" & str: Exit Function
        If InStr(1, str, ".") > 0 Then Проверка_слова = "'" & str: Exit Function
        If InStr(1, str, "/") > 0 Then Проверка_слова = "'" & str: Exit Function
        Проверка_слова = str * 1: Exit Function
End Function
Function IsArrayEmpty(anArray As Variant) As Boolean
On Error GoTo IS_EMPTY
If (UBound(anArray) >= 0) Then Exit Function
IS_EMPTY:
        IsArrayEmpty = True
End Function