[Iska]

1. Область данных так и будет всегда начинаться с «B1»?
2. Количество переменных всегда будет равно семи?
3. «и для каждой переменной…» — всегда будет присутствовать для каждой?
4. «…после него есть 3 переменных» — всегда равно трём?
5. «Сначала идет желтое поле (сколько бы колонок в нем не было)» — «жёлтое поле» всегда будет присутствовать?
6. Что за непонятные значения ячеек «лист1», «лист2»? Что за заголовок столбца «ч3»?
7. «затем тоже самое.» — между предыдущим и последующим «тем же самым» интервал должен быть именно три столбца?
8. Имена «переменных» будут именно «x1»…, «y»?

Для образца я просто написал для 4х переменных. »

Вам было лень? Оставили работу для отвечающего? Сделайте это до конца. Исправьте заголовок столбца «ч3».

[golovatov]

здравствуйте,Iska.

1. Область данных так и будет всегда начинаться с «B1»? »

да

2. Количество переменных всегда будет равно семи? »

нет, их может быть с x1 по x100 или x1000
тогда нетрудно подсчитать, что если 1000 переменных, то после желтого поля будет 3 000 столбцов. Я думаю Вы поняли

3. «и для каждой переменной…» — всегда будет присутствовать для каждой? »

да обязательно всегда
если есть x1000, то для нее будет три x1000 x1000 x1000

5. «Сначала идет желтое поле (сколько бы колонок в нем не было)» — «жёлтое поле» всегда будет присутствовать? »

верно, всегда

6. Что за непонятные значения ячеек «лист1», «лист2»? Что за заголовок столбца «ч3»? »

извините, ч3 опечатка там x3
лист1, лист2, просто попытался разделить, ну, т.е. чтобы вот так на выходи были данные.

7. «затем тоже самое.» — между предыдущим и последующим «тем же самым» интервал должен быть именно три столбца? »

да.
x1 -x1x1x1
x2-x2x2x2

8. Имена «переменных» будут именно «x1»…, «y»? »

а вот тут нет. будут другие названия
это я как шаблон привел. Названия всегда будут в первой строке.

Вам было лень? Оставили работу для отвечающего? Сделайте это до конца. Исправьте заголовок столбца «ч3». »

переделал
Но это просто как шаблон.

[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 мой конек, сначала потестируйте на правильность работы с разными наборами данных.

[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