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
         If IsNumeric(str) Then Проверка_слова = str * 1 Else Проверка_слова = str
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