let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(Source, {"Наименования"}, "Attribute", "Value"),
    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Attribute"})
in
    #"Removed Columns"

Sub macro_1()
Dim arr As Variant, v As Variant, title, j As Long
Dim lc As Long, i As Long, lr As Long, tmp As String

title = Array("Наименования", "Все заполненные хар-ки")

With Worksheets("1") ' res - это имя листа с данными
    arr = .Cells(3, 1).CurrentRegion
    lc = UBound(arr, 2)
End With
With Worksheets("res") ' res - это имя листа с результатом
.Cells.Clear
lr = 1
.Cells(lr, 1).Resize(1, UBound(title) + 1) = title
    For i = 3 To UBound(arr, 1)
    tmp = arr(i, 1)
        v = get_array(insertion_sort(arr, i), i, tmp)
        .Cells(lr + 1, 1) = v(UBound(v))
        For j = LBound(v) To UBound(v) - 1
            .Cells(lr + 1, 2) = v(j)
            lr = lr + 1
        Next j
    Next i
    format .Cells(1, 1).CurrentRegion
End With
End Sub
Private Sub format(rng As Range)
    rng.Borders.Weight = xlThin
    rng.HorizontalAlignment = xlLeft
    rng.Rows(1).Font.Bold = True
    rng.Rows(1).HorizontalAlignment = xlCenter
End Sub
Private Function insertion_sort(arr, k) As Variant
    Dim i, j, key
    For i = 2 To UBound(arr, 2)
        j = i - 1
        key = arr(k, i)
        Do While j > 0 And arr(k, j) > key
            arr(k, j + 1) = arr(k, j)
            j = j - 1
            If j = 0 Then Exit Do
        Loop
        arr(k, j + 1) = key
    Next i
    insertion_sort = arr
End Function
Private Function get_array(arr, k, nameCol) As Variant
Dim res(), i As Long, j As Long, tmp, tmp_
i = UBound(arr, 2)
j = 1
Do
    If nameCol = arr(k, i) Then tmp = j
    ReDim Preserve res(1 To j)
    res(j) = arr(k, i)
    j = j + 1
    i = i - 1
    If i = 0 Then Exit Do
Loop While Not IsEmpty(arr(k, i))
tmp_ = res(UBound(res))
res(UBound(res)) = res(tmp)
res(tmp) = tmp_
get_array = res
End Function