т.е. по факту мы раздвигаем каждую характеристику и вписываем категорию из соответствующей строки и название из шапки а в шапке прописывается Attr. Group 1|Attribute 1|Attribute value 1
Написал вот такой код, все работает, Хотя 100% неоптимальный.
Код
Sub Add_atribute()
'определяем начало характеристик
Dim start As Integer
start = 12
'определяем последнюю заполненную колонку справа
Dim lLastCol As Long
lLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'определяем последнюю заполненную строку
Dim lLastRow As Long
lLastRow = Cells(Rows.Count, start).End(xlUp).Row
'вычисляем размерность массива
Dim w As Integer
w = lLastCol - start
Dim b As Variant
ReDim b(1 To lLastRow, 1 To w * 3)
'ReDim b(1 To 5, 1 To 6)
Dim a As Variant
Dim y As Integer
'a = Range(Cells(1, 12), Cells(5, 14))
a = Range(Cells(1, 12), Cells(lLastRow, lLastCol))
Count = UBound(a, 2) - LBound(a, 2) + 1
For x = 2 To UBound(b)
zz = 0
ii = 0
p = 1
For y = 2 To Count
'записываем шапку
ii = ii + 1
b(1, ii) = "Attr. Group " & p
ii = ii + 1
b(1, ii) = "Attribute " & p
ii = ii + 1
b(1, ii) = "Attribute value " & p
' записываем категорию
zz = zz + 1
b(x, zz) = a(x, 1)
' записываем Год
zz = zz + 1
b(x, zz) = a(1, y)
' записываем value
zz = zz + 1
b(x, zz) = a(x, y)
p = p + 1
Next y
Next x
Sheets("OUT").Cells(1, 1).Resize(UBound(b), UBound(b, 2)) = b
End Sub