Option Explicit

' arr - двумерный массив (соответствует диапазону ячеек).
' Возвращает массив с 3 столбцами:
' - заголовок строки
' - заголовок столбца
' - значение непустой ячейки на пересечении
Function UnPivot(ByVal arr)
  Dim i As Long, j As Long, L1 As Long, L2 As Long, n As Long, reg As Long, res
 
  L1 = LBound(arr, 1)
  L2 = LBound(arr, 2)
  ' reg=1: считаем непустые ячейки
  ' reg=2: заполняем массив
  For reg = 1 To 2
    If reg = 2 Then
      If n = 0 Then ' Нет непустых ячеек
        Exit Function
      Else
        ReDim res(1 To n, 1 To 3)
        n = 0
      End If
    End If
  
    For i = L1 + 1 To UBound(arr, 1)
    For j = L2 + 1 To UBound(arr, 2)
      If Not IsEmpty(arr(i, j)) Then
        n = n + 1
        If reg = 2 Then
          res(n, 1) = arr(i, L2)
          res(n, 2) = arr(L1, j)
          res(n, 3) = arr(i, j)
        End If
      End If
    Next j
    Next i
  Next reg
  
  UnPivot = res
End Function

Sub Test()
  Dim arr, res
  arr = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion.Value
  res = UnPivot(arr)
  With ThisWorkbook.Worksheets(2)
    .Cells.Delete
    .Range("A1").Resize(UBound(res, 1), UBound(res, 2)).FormulaLocal = res
    .Columns("A:C").AutoFit
  End With
  
End Sub

Sub Redesigner()
Dim i&, r&, c%, j%, k%, hc%, hr%, shRez As Worksheet, inData As Range
hr = 1
hc = 1
Application.ScreenUpdating = False
    Set inData = ActiveSheet.Cells(1).CurrentRegion
    Set shRez = Worksheets.Add
     
For r = (hr + 1) To inData.Rows.Count
    For c = (hc + 1) To inData.Columns.Count
    If inData.Cells(r, c) <> "" Then
    i = i + 1
        For j = 1 To hc
            shRez.Cells(i, j) = inData.Cells(r, j)
        Next j
        For k = 1 To hr
            shRez.Cells(i, j + k - 1) = inData.Cells(k, c)
        Next k
        shRez.Cells(i, j + k - 1) = inData.Cells(r, c)
    End If
    Next c
Next r
End Sub