Добрый день, очень нужен запрос наоборот. Есть данные в столбец, нужно транспонировать в строку.
Исходные данные, выделенные жёлтым, нужно сделать в формате, выделенным голубым.
Прилагаю макрос, который быстро работает на больших массивах(преобразует строку в столбец, мне нужен обратный)
Спасибо большое!!!
Код |
---|
Sub Trans()
Dim rngHor As Range
Dim rngVer As Range
Dim rngOut As Range
Dim counter As Long
Dim lngRow As Long
Dim cell As Range
Set rngHor = Application.InputBox("Enter Data range", Type:=8)
Set rngVer = Application.InputBox("Enter Vertical range", Type:=8)
Set rngOut = Application.InputBox("Enter Output range", Type:=8)
For Each cell In rngVer
DoEvents
rngOut(counter + 1, 1).Resize(rngHor.Columns.Count, 1).Value2 = cell
rngOut(counter + 1, 2).Resize(rngHor.Columns.Count, 1).Value2 = WorksheetFunction.Transpose(rngHor.Rows(lngRow + 1))
lngRow = lngRow + 1
counter = counter + rngHor.Columns.Count
Next
Const lCol As Long = 2 'Номер слобца,где ищем пустые ячейки
Const lFirstRow As Long = 1 'Номер строки с которой начинаем отчёт
Dim li As Long, lLastRow As Long, lCalc As Long
With Application
'Для ускорения выполнения Отключаем обновление экрна и пересчет формул
.ScreenUpdating = 0: lCalc = .Calculation: .Calculation = xlManual 'идем циклом по всем ячейкам столбца lCol
For li = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1 To lFirstRow Step -1
'Если ячейка пустая - удаляем строку.
If Cells(li, lCol) = "" Then Rows(li).Delete
Next li
'возвращаем обновление экрна и пересчет формул
.ScreenUpdating = 1: .Calculation = lCalc
End With
End Sub
|