[a_axe]

golovatov, попробуйте такой код:

Код

Код:

Public Sub table_sort()
Dim dataSht As Worksheet, newSht As Worksheet
Dim objCell As Range, DataRange  As Range
Dim i As Integer, i1 As Integer, i2 As Integer, j As Integer, k As Integer
Set dataSht = ActiveWorkbook.ActiveSheet
Set DataRange = dataSht.UsedRange
For i = DataRange.Column To DataRange.Column + DataRange.Columns.Count - 1
    If dataSht.Cells(DataRange.Row, i).Interior.Color = 65535 Then
        If i1 = 0 Then i1 = i Else i2 = i
    End If
Next i
For k = i1 - 1 To DataRange.Column Step -1
    If Intersect(dataSht.Columns(k), DataRange.Rows(1)).Value <> "" Then
        Range(Rows(DataRange.Rows.Count + 2), Rows(2 * DataRange.Rows.Count + 2)).EntireRow.Insert
        Intersect(DataRange, Range(Columns(i1), Columns(i2)).EntireColumn).Copy
        Cells(DataRange.Rows.Count + 3, 1).Select
        ActiveSheet.Paste
        Intersect(DataRange, Range(Columns(k), Columns(k)).EntireColumn).Copy
        ActiveCell.Offset(0, i2 - i1 + 1).Select
        ActiveSheet.Paste
            For j = i2 + 1 To DataRange.Columns.Count
                If dataSht.Cells(1, j).Value = ActiveCell.Value And dataSht.Cells(1, j).Value = dataSht.Cells(1, j + 1).Value And dataSht.Cells(1, j).Value = dataSht.Cells(1, j + 2).Value Then
                    ActiveCell.Offset(0, 1).Select
                    Intersect(DataRange, Range(Columns(j), Columns(j + 2)).EntireColumn).Copy
                    ActiveSheet.Paste
                    Exit For
                End If
            Next j
      
    End If
Next k

Set DataRange = Nothing
Set dataSht = Nothing
End Sub

Оговорки: кроме исходной таблицы на листе не должно ничего быть. Если название переменных Хi и хi,хi,хi не совпадают с положенным им Вами местом - сознательно копировать не будет, так как нарушена указанная Вами структура данных, т.е. останется пустое место. Заголовки должны находиться в первой строке.
не могу сказать, что VBA мой конек, сначала потестируйте на правильность работы с разными наборами данных.