[a_axe]

golovatov, учитывая озвученные Вами требования по несовпадению названий переменных Хi и xi,xi,xi код изменится следующим образом:

код

Код:

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 Right(dataSht.Cells(1, j).Value, Len(ActiveCell.Value)) = ActiveCell.Value And Right(dataSht.Cells(1, j + 1).Value, Len(ActiveCell.Value)) = ActiveCell.Value And Right(dataSht.Cells(1, j + 2).Value, Len(ActiveCell.Value)) = ActiveCell.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