Помогите преобразовать "3D" таблицы в листе в "плоский" вид

Программирование на Visual Basic for Applications
golland
Начинающий
Начинающий
 
Сообщения: 4
Зарегистрирован: 05.07.2011 (Вт) 19:06

Помогите преобразовать "3D" таблицы в листе в "плоский" вид

Сообщение golland » 05.07.2011 (Вт) 19:18

Есть прайс-лист с такими данными
3d_list1.png
3d_list1.png (21.81 Кб) Просмотров: 3779

Хочется получить данные в "плоском" виде, вот так:
flat_list2.png

для этого использовать VBA макрос.
Т.е. нужно по форматированию найти название отеля (или как то по другому), затем перевести шапку таблицы с объединенными ячейками в список и т.д.
Реально ли это сделать средствами VBA?

В приложении файл xls, в листе №1 исходные данные, в листе №2 данные которые хотелось бы получить (создавал вручную, потратил 40мин на это).
Заранее спасибо за ответы.
Вложения
oteli_from_3d_to_flat.xls
(29.5 Кб) Скачиваний: 167

mshak
Обычный пользователь
Обычный пользователь
 
Сообщения: 59
Зарегистрирован: 29.01.2008 (Вт) 14:17

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение mshak » 05.07.2011 (Вт) 21:17

реально, но тебе прийдется написать макрос который распарсит лист с так называемыми "3D" таблицами и соберет все воедино (например на втором листе)

golland
Начинающий
Начинающий
 
Сообщения: 4
Зарегистрирован: 05.07.2011 (Вт) 19:06

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение golland » 05.07.2011 (Вт) 22:00

Был бы признательным, если бы кто то какой-либо алгоритм (код) показал.

Qwertiy
Доктор VB наук
Доктор VB наук
 
Сообщения: 2753
Зарегистрирован: 26.06.2011 (Вс) 21:26

Сообщение Qwertiy » 05.07.2011 (Вт) 22:12

golland писал(а):Был бы признательным, если бы кто то какой-либо алгоритм (код) показал.

Алгорит придумать не так-то просто... Но понятно, что это вполне возможно.
В MS Office достаточно хорошо реализовано программирование макросов, радуйтесь, что Вам не в OOo это делать.

ger_kar
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1957
Зарегистрирован: 19.05.2011 (Чт) 19:23
Откуда: Кыргызстан, Иссык-Куль, г. Каракол

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение ger_kar » 06.07.2011 (Ср) 7:52

Ну я готов помочь, но конечно не всю работу от А до Я выполнить, а помочь в реализации, а для этого мне хотелось бы знать твой уровень знаний, т.е. насколько ты хорошо знаешь объектную модель Excel. Например знаком ли ты с Range Cells и т.д. И что уже было сделано. Мне надо определиться с чего начать?
Бороться и искать, найти и перепрятать

golland
Начинающий
Начинающий
 
Сообщения: 4
Зарегистрирован: 05.07.2011 (Вт) 19:06

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение golland » 06.07.2011 (Ср) 9:45

мне хотелось бы знать твой уровень знаний, т.е. насколько ты хорошо знаешь объектную модель Excel. Например знаком ли ты с Range Cells и т.д.

С объектной моделью MS Excel знаком, не досконально, но небольшой опыт есть. Работал с Range, Cells и т.д.
И что уже было сделано. Мне надо определиться с чего начать?

Пока еще ничего не сделано, пытаюсь понять как это лучше сделать, чтобы универсальнее получилось.

alibek
Большой Человек
Большой Человек
 
Сообщения: 14205
Зарегистрирован: 19.04.2002 (Пт) 11:40
Откуда: Russia

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение alibek » 06.07.2011 (Ср) 9:59

golland писал(а):Был бы признательным, если бы кто то какой-либо алгоритм (код) показал.

Универсального алгоритма не существует, он зависит от того, какая схема группировки применяется.
В данном случае схема такая:
1 уровень — строка с предшествующей пустой строкой.
остальные уровни — определяются сгруппированные ячейки и по ним строится иерархия.
Lasciate ogni speranza, voi ch'entrate.

ger_kar
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1957
Зарегистрирован: 19.05.2011 (Чт) 19:23
Откуда: Кыргызстан, Иссык-Куль, г. Каракол

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение ger_kar » 06.07.2011 (Ср) 11:20

Но сначала нужно определиться с диапазоном сканирования, т.е. определить крайний правый столбец и крайнюю нижнюю строку, потом собственно в цикле начинать сканирование с первой строки до последней.
Бороться и искать, найти и перепрятать

ger_kar
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1957
Зарегистрирован: 19.05.2011 (Чт) 19:23
Откуда: Кыргызстан, Иссык-Куль, г. Каракол

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение ger_kar » 06.07.2011 (Ср) 20:06

Настало время перейти от слов к коду :) Вот слабал по быстрому такой код, немного коряво, но общий принцип уловить можно.
Доработаешь сам. Если что, поможем чем сможем :)

Код: Выделить всё
Option Explicit

Dim lngRowSourceBeg As Long         'Указатель на первую строку скан. диапазона
Dim lngColSourceBeg As Long         'Указатель на первую колонку скан. диапазона
Dim lngRowSourceEnd As Long         'Указатель на послед. строку скан. диапазона
Dim lngColSourceEnd As Long         'Указатель на послед. колонку скан. диапазона
Dim lngRowSourceCur As Long         'Указатель на текущую стр. скан. диапазона
Dim lngColSourceCur As Long         'Указатель на текущую колон. скан. диапазона
Dim lngRowName1     As Long
Dim lngRowName2     As Long

Dim lngRowTargetCur As Long         '
Dim lngColTargetCur As Long         '
Dim objSheetSource  As Worksheet    '
Dim objSheetTarget  As Worksheet    '
Dim varValue As Variant
Dim lngIndex As Long
'
Public Sub Main()
    'Определяем начало и конец диапазона сканирования листа источника
    Set objSheetSource = Worksheets(1)  'Назначаем лист источник
    Set objSheetTarget = Worksheets(2)  'Назначаем лист цель (куда копировать)
    objSheetSource.Activate
    lngRowTargetCur = 1: lngColTargetCur = 1
    With objSheetSource.UsedRange
        lngRowSourceBeg = .Row
        lngColSourceBeg = .Column
        lngRowSourceEnd = lngRowSourceBeg + .Rows.Count - 1
        lngColSourceEnd = lngColSourceBeg + .Columns.Count - 1
    End With
    'Запускаем цикл сканирования
    For lngRowSourceCur = lngRowSourceBeg To lngRowSourceEnd
        varValue = objSheetSource.Cells(lngRowSourceCur, 1)
        If Not IsEmpty(varValue) <> 0 Then
            If objSheetSource.Cells(lngRowSourceCur, 1).Font.Bold = True And _
               IsEmpty(objSheetSource.Cells(lngRowSourceCur - 1, 1)) Then
                 lngRowName1 = lngRowSourceCur + 1
                 lngRowName2 = lngRowSourceCur + 2
                 lngRowSourceCur = lngRowSourceCur + 3
                 For lngIndex = 1 To 4
                    For lngColSourceCur = 3 To lngColSourceEnd
                       If Not IsEmpty(objSheetSource.Cells(lngRowSourceCur, lngColSourceCur)) Then
                           With objSheetTarget
                               .Cells(lngRowTargetCur, lngColTargetCur) = varValue
                               objSheetSource.Cells(lngRowSourceCur, 1).Select
                               .Cells(lngRowTargetCur, lngColTargetCur + 1) = ActiveCell.Value
                               .Cells(lngRowTargetCur, lngColTargetCur + 2) = objSheetSource.Cells(lngRowSourceCur, 2)
                               objSheetSource.Cells(lngRowName1, lngColSourceCur).Select
                               .Cells(lngRowTargetCur, lngColTargetCur + 3) = ActiveCell.Value
                               .Cells(lngRowTargetCur, lngColTargetCur + 4) = objSheetSource.Cells(lngRowName2, lngColSourceCur)
                               .Cells(lngRowTargetCur, lngColTargetCur + 5) = objSheetSource.Cells(lngRowSourceCur, lngColSourceCur)
                               .Columns("A:F").Columns.AutoFit
                               lngRowTargetCur = lngRowTargetCur + 1
                           End With
                       End If
                    Next lngColSourceCur
                    lngRowSourceCur = lngRowSourceCur + 1
                 Next lngIndex
            End If
        End If
    Next lngRowSourceCur
End Sub
Бороться и искать, найти и перепрятать

alibek
Большой Человек
Большой Человек
 
Сообщения: 14205
Зарегистрирован: 19.04.2002 (Пт) 11:40
Откуда: Russia

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение alibek » 06.07.2011 (Ср) 22:27

ger_kar писал(а):Но сначала нужно определиться с диапазоном сканирования, т.е. определить крайний правый столбец и крайнюю нижнюю строку, потом собственно в цикле начинать сканирование с первой строки до последней.

В чем проблема? Смотри UsedRange.
Или перебирай в цикле до двух пустых строк подряд.
Lasciate ogni speranza, voi ch'entrate.

ger_kar
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1957
Зарегистрирован: 19.05.2011 (Чт) 19:23
Откуда: Кыргызстан, Иссык-Куль, г. Каракол

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение ger_kar » 07.07.2011 (Чт) 5:41

alibek писал(а):В чем проблема? Смотри UsedRange.
Да собственно проблемы нет. Наоборот это была подсказка с чего начинать.
alibek писал(а):Или перебирай в цикле до двух пустых строк подряд
Тоже вариант, но ИМХО UsedRange лучше, а то мало ли какие могут встретиться сюрпризы форматирования в виде пропушенных строк :)
Теперь по коду. Хотел сделать при сканировании самой таблицы получение заголовков через MergeArea. Т.е. по ячейке входящей в объединенную ячейку с заголовком получить Range объединенной ячейки, и по нему значение, но гадский (сколько уже раз он меня подводил) MergeArea опять ушел в глухой отказ и полную несознанку :) Поэтому пришлось применить как всегда безотказный Select :) Получилось коряво, но зато работает. Также еще один глюк встретился, но сейчас про него излагать уже некогда, подождет до вечера :)
Бороться и искать, найти и перепрятать

ger_kar
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1957
Зарегистрирован: 19.05.2011 (Чт) 19:23
Откуда: Кыргызстан, Иссык-Куль, г. Каракол

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение ger_kar » 07.07.2011 (Чт) 10:23

Вот немного подправленный код и собственно сам проект. Проблему UsedRange победить не смог, оставил Select.
Код: Выделить всё
Option Explicit

Dim lngRowSourceBeg As Long         'Указатель на первую строку скан. диапазона
Dim lngColSourceBeg As Long         'Указатель на первую колонку скан. диапазона
Dim lngRowSourceEnd As Long         'Указатель на послед. строку скан. диапазона
Dim lngColSourceEnd As Long         'Указатель на послед. колонку скан. диапазона
Dim lngRowSourceCur As Long         'Указатель на текущую стр. скан. диапазона
Dim lngColSourceCur As Long         'Указатель на текущую колон. скан. диапазона
Dim lngRowName1     As Long         'Указатель на строку общего верхнего заголовка
Dim lngRowName2     As Long         'Указатель на строку заголовков столбцов
Dim lngRowTargetCur As Long         'Указатель на текущую заполняемую строку на новом листе
Dim objSheetSource  As Worksheet    'Лист источник
Dim objSheetTarget  As Worksheet    'Лист цель (заполняемый новый лист)
Dim varValue As Variant             'Наименование таблицы
'
Public Sub Main()
    'Определяем начало и конец диапазона сканирования листа источника
    Set objSheetSource = Worksheets(1)  'Назначаем лист источник
    Set objSheetTarget = Worksheets(2)  'Назначаем лист цель (куда копировать)
    objSheetSource.Activate
    lngRowTargetCur = 1
    Columns("B:B").NumberFormat = "mm/dd/yyyy"
    With objSheetSource.UsedRange
        lngRowSourceBeg = .Row
        lngColSourceBeg = .Column
        lngRowSourceEnd = lngRowSourceBeg + .Rows.Count - 1
        lngColSourceEnd = lngColSourceBeg + .Columns.Count - 1
    End With
    'Запускаем цикл сканирования
    For lngRowSourceCur = lngRowSourceBeg To lngRowSourceEnd
        varValue = objSheetSource.Cells(lngRowSourceCur, 1)
        If Not IsEmpty(varValue) <> 0 Then
            If objSheetSource.Cells(lngRowSourceCur, 1).Font.Bold = True And _
               IsEmpty(objSheetSource.Cells(lngRowSourceCur - 1, 1)) Then
                 lngRowName1 = lngRowSourceCur + 1
                 lngRowName2 = lngRowSourceCur + 2
                 lngRowSourceCur = lngRowSourceCur + 3
                 Do
                    For lngColSourceCur = 3 To lngColSourceEnd
                       If Not IsEmpty(objSheetSource.Cells(lngRowSourceCur, lngColSourceCur)) Then
                           With objSheetTarget
                               .Cells(lngRowTargetCur, 1) = varValue
                                objSheetSource.Cells(lngRowSourceCur, 1).Select
                               .Cells(lngRowTargetCur, 2) = CDate(ActiveCell.Value)
                               .Cells(lngRowTargetCur, 3) = objSheetSource.Cells(lngRowSourceCur, 2)
                                objSheetSource.Cells(lngRowName1, lngColSourceCur).Select
                               .Cells(lngRowTargetCur, 4) = ActiveCell.Value
                               .Cells(lngRowTargetCur, 5) = objSheetSource.Cells(lngRowName2, lngColSourceCur)
                               .Cells(lngRowTargetCur, 6) = objSheetSource.Cells(lngRowSourceCur, lngColSourceCur)
                               .Columns("A:F").Columns.AutoFit
                               lngRowTargetCur = lngRowTargetCur + 1
                           End With
                       End If
                    Next lngColSourceCur
                    lngRowSourceCur = lngRowSourceCur + 1
                 Loop Until IsEmpty(objSheetSource.Cells(lngRowSourceCur, 2))
            End If
        End If
    Next lngRowSourceCur
End Sub

oteli_from_3d_to_flat.xls
(46 Кб) Скачиваний: 159
Бороться и искать, найти и перепрятать

golland
Начинающий
Начинающий
 
Сообщения: 4
Зарегистрирован: 05.07.2011 (Вт) 19:06

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение golland » 07.07.2011 (Чт) 11:18

Вчера сделал на основании вашего ответа, чтобы из таблиц считывались все строки, было ограничение только на 4 строки, т.к. в примере их было всего 4 в каждой таблице, а если их было больше, то они не считывались. Хотел сегодня здесь разместить доработанный мною вариант, но вы меня опередили и разместили лучшую реализацию считывания всех строк из таблиц в листе. Огромное спасибо Вам за помощь, слов нет, очень рад!

ger_kar
Продвинутый гуру
Продвинутый гуру
Аватара пользователя
 
Сообщения: 1957
Зарегистрирован: 19.05.2011 (Чт) 19:23
Откуда: Кыргызстан, Иссык-Куль, г. Каракол

Re: Помогите преобразовать "3D" таблицы в листе в "плоский"

Сообщение ger_kar » 08.07.2011 (Пт) 18:26

Сделал таки без Select (ну не нравился мне код с его использованием) вот этот вариант:
Код: Выделить всё
Option Explicit

Dim lngRowSourceBeg As Long         'Указатель на первую строку скан. диапазона
Dim lngColSourceBeg As Long         'Указатель на первую колонку скан. диапазона
Dim lngRowSourceEnd As Long         'Указатель на послед. строку скан. диапазона
Dim lngColSourceEnd As Long         'Указатель на послед. колонку скан. диапазона
Dim lngRowSourceCur As Long         'Указатель на текущую стр. скан. диапазона
Dim lngColSourceCur As Long         'Указатель на текущую колон. скан. диапазона
Dim lngRowName1     As Long         'Указатель на строку общего верхнего заголовка
Dim lngRowName2     As Long         'Указатель на строку заголовков столбцов
Dim lngRowTargetCur As Long         'Указатель на текущую заполняемую строку на новом листе
Dim objSheetSource  As Worksheet    'Лист источник
Dim objSheetTarget  As Worksheet    'Лист цель (заполняемый новый лист)
Dim varValue As Variant             'Наименование таблицы
'

Public Sub Main()
    'Определяем начало и конец диапазона сканирования листа источника
    Set objSheetSource = Worksheets(1)  'Назначаем лист источник
    Set objSheetTarget = Worksheets(2)  'Назначаем лист цель (куда копировать)
    lngRowTargetCur = 1
    Columns("B:B").NumberFormat = "mm/dd/yyyy"
    With objSheetSource.UsedRange
        lngRowSourceBeg = .Row
        lngColSourceBeg = .Column
        lngRowSourceEnd = lngRowSourceBeg + .Rows.Count - 1
        lngColSourceEnd = lngColSourceBeg + .Columns.Count - 1
    End With
    'Запускаем цикл сканирования
    For lngRowSourceCur = lngRowSourceBeg To lngRowSourceEnd
        varValue = objSheetSource.Cells(lngRowSourceCur, 1)
        If Not IsEmpty(varValue) <> 0 Then
            If objSheetSource.Cells(lngRowSourceCur, 1).Font.Bold = True And _
               IsEmpty(objSheetSource.Cells(lngRowSourceCur - 1, 1)) Then
                 lngRowName1 = lngRowSourceCur + 1
                 lngRowName2 = lngRowSourceCur + 2
                 lngRowSourceCur = lngRowSourceCur + 3
                 Do
                    For lngColSourceCur = 3 To lngColSourceEnd
                       If Not IsEmpty(objSheetSource.Cells(lngRowSourceCur, lngColSourceCur)) Then
                           With objSheetTarget
                               .Cells(lngRowTargetCur, 1) = varValue
                               .Cells(lngRowTargetCur, 2) = CDate(U_Val(lngRowSourceCur, 1))
                               .Cells(lngRowTargetCur, 3) = U_Val(lngRowSourceCur, 2)
                               .Cells(lngRowTargetCur, 4) = U_Val(lngRowName1, lngColSourceCur)
                               .Cells(lngRowTargetCur, 5) = U_Val(lngRowName2, lngColSourceCur)
                               .Cells(lngRowTargetCur, 6) = U_Val(lngRowSourceCur, lngColSourceCur)
                               .Columns("A:F").Columns.AutoFit
                               lngRowTargetCur = lngRowTargetCur + 1
                           End With
                       End If
                    Next lngColSourceCur
                    lngRowSourceCur = lngRowSourceCur + 1
                 Loop Until IsEmpty(objSheetSource.Cells(lngRowSourceCur, 2))
            End If
        End If
    Next lngRowSourceCur
End Sub

Public Function U_Val(Row As Long, Column As Long) As Variant
    Dim varValue As Variant
    varValue = objSheetSource.Cells(Row, Column).MergeArea.Value
    If IsArray(varValue) Then U_Val = varValue(1, 1) Else U_Val = varValue
End Function
Бороться и искать, найти и перепрятать


Вернуться в VBA

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 5

    TopList