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

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

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

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

Тут мы видим, что у нас есть 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.
Переменных у меня сотни в работе, но есть строгий порядок их следования, его нельзя нарушать.
Кому нетрудно помогите написать макрос, который эту механическую работу облегчает.

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

Цитата:

Цитата golovatov

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

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

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

Цитата:

Цитата Iska

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

да

Цитата:

Цитата Iska

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

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

Цитата:

Цитата Iska

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

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

Цитата:

Цитата Iska

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

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

Цитата:

Цитата Iska

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

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

Цитата:

Цитата Iska

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

да.
x1 -x1x1x1
x2-x2x2x2

Цитата:

Цитата Iska

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

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

Цитата:

Цитата Iska

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

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

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

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