[решено] автоматизация переструктурирования данных

[golovatov]

Здравствуйте, помогите пожалуйста, мне облегчить задачу. Вот здесь эксель файл:

Тут мы видим, что у нас есть 7 переменных: x1-x7,желтое поле и для каждой переменной после него есть 3 переменных.
Например, для переменной Х1, есть 3 переменных х1,х1,х1
для переменной Х2, есть 3 переменных х2,х2,х2. и так далее. Для образца я просто написал для 4х переменных.
Нужно переструктурировать данные.
Сначала идет желтое поле (сколько бы колонок в нем не было) - потом- переменная х1-а потом ровно 3 переменных x1,x1,x1

затем тоже самое.
желтое поле(оно всегад статично)-переменная х2- и за ней 3 переменных x2, x2,x2.
Переменных у меня сотни в работе, но есть строгий порядок их следования, его нельзя нарушать.
Кому нетрудно помогите написать макрос, который эту механическую работу облегчает.

[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