Страницы: 1
RSS
Преобазовать кросс-таблицу в плоскую с игнорированием пустых значений
 
Есть очень большая таблица.
Столб.1 (тут куча столбцов которые не трогаем) Столб.33  Столб.34  Столб.35  Столб.36  Столб.37
Проект1 (тут куча столбцов которые не трогаем)          дата           дата         пусто        пусто        Текст
Проект2 (тут куча столбцов которые не трогаем)          дата           пусто        Текст        дата          Текст
Проект3 (тут куча столбцов которые не трогаем)          пусто          дата         Текст        пусто        пусто        

Труебуется на основании наличия данных (не пусто) преобразовать данные вот к такому виду:
Столб.1 (тут куча столбцов которые не трогаем)          Наши данные
Проект1 (тут куча столбцов которые не трогаем)                 дата
Проект1 (тут куча столбцов которые не трогаем)                 дата  
Проект1 (тут куча столбцов которые не трогаем)                 Текст
Проект2 (тут куча столбцов которые не трогаем)                 дата
Проект2 (тут куча столбцов которые не трогаем)                 Текст
Проект2 (тут куча столбцов которые не трогаем)                  дата
Проект2 (тут куча столбцов которые не трогаем)                 Текст
Проект3 (тут куча столбцов которые не трогаем)                  дата
Проект3 (тут куча столбцов которые не трогаем)                 Текст

Т.е. столбцы с 33 по 37 при наличии в них данных порождают клонирование строк. А сами данные перемещаются в один столбец.
Файл с примером

Помогите пожалуйста
 
Цитата
Vadim Vadimov написал:
не уверен, что термин применим
Попробуйте переформулировать задачу - модераторы поменяют.
 
Цитата
Юрий М написал:
модераторы поменяют
Видимо мне уже помогли Вы или Модератор, тема получило крутое название. Спасибо.
 
Попробуйте так

Код
Sub TransposeTableByColumns33_37()
Dim arrData, iRow As Long, iCol As Long, iRowRes As Long, iColRes As Long, TotalRows As Long

    arrData = Range("A1").CurrentRegion
    TotalRows = Application.CountA(Range("AG:AK"))
    ReDim arrresult(1 To TotalRows, 1 To 33)
    
    For iRow = 2 To UBound(arrData)
        For iCol = 1 To UBound(arrData, 2)
            If iCol >= 33 And Len(arrData(iRow, iCol)) > 0 Then
                iRowRes = iRowRes + 1
                For iColRes = 1 To UBound(arrresult, 2)
                    arrresult(iRowRes, iColRes) = arrData(iRow, iColRes)
                    If iColRes = UBound(arrresult, 2) Then arrresult(iRowRes, iColRes) = arrData(iRow, iCol)
                Next iColRes
            End If
        Next iCol
    Next iRow
    
    Workbooks.Add
    Range("A2").Resize(UBound(arrresult, 1), UBound(arrresult, 2)).Value = arrresult

End Sub
Изменено: New - 07.04.2021 20:23:29
 
Да простят меня модераторы и удалят пост если нельзя.
Кажется я нашел штатное решение
 
del
Изменено: buchlotnik - 23.08.2021 15:37:30
Соблюдение правил форума не освобождает от модераторского произвола
Страницы: 1
Наверх