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

[golland]

Есть прайс-лист с такими данными

3d_list1.png (21.81 Кб) Просмотров: 3905

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

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

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

[mshak]

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

[golland]

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

[Qwertiy]

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

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

[ger_kar]

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

[golland]

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

С объектной моделью MS Excel знаком, не досконально, но небольшой опыт есть. Работал с Range, Cells и т.д.

И что уже было сделано. Мне надо определиться с чего начать?

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

[alibek]

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

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

[ger_kar]

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

[ger_kar]

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

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

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]

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

В чем проблема? Смотри UsedRange.
Или перебирай в цикле до двух пустых строк подряд.

[ger_kar]

В чем проблема? Смотри UsedRange.

Да собственно проблемы нет. Наоборот это была подсказка с чего начинать.

Или перебирай в цикле до двух пустых строк подряд

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

[ger_kar]

Вот немного подправленный код и собственно сам проект. Проблему 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 Кб) Скачиваний: 166

[golland]

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

[ger_kar]

Сделал таки без 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