Есть очень большая таблица. Столб.1 (тут куча столбцов которые не трогаем) Столб.33 Столб.34 Столб.35 Столб.36 Столб.37 Проект1 (тут куча столбцов которые не трогаем) дата дата пусто пусто Текст Проект2 (тут куча столбцов которые не трогаем) дата пусто Текст дата Текст Проект3 (тут куча столбцов которые не трогаем) пусто дата Текст пусто пусто
Труебуется на основании наличия данных (не пусто) преобразовать данные вот к такому виду: Столб.1 (тут куча столбцов которые не трогаем) Наши данные Проект1 (тут куча столбцов которые не трогаем) дата Проект1 (тут куча столбцов которые не трогаем) дата Проект1 (тут куча столбцов которые не трогаем) Текст Проект2 (тут куча столбцов которые не трогаем) дата Проект2 (тут куча столбцов которые не трогаем) Текст Проект2 (тут куча столбцов которые не трогаем) дата Проект2 (тут куча столбцов которые не трогаем) Текст Проект3 (тут куча столбцов которые не трогаем) дата Проект3 (тут куча столбцов которые не трогаем) Текст
Т.е. столбцы с 33 по 37 при наличии в них данных порождают клонирование строк. А сами данные перемещаются в один столбец. Файл с примером
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