Страницы: 1
RSS
Выставить столбцы друг под другом
 
Добрый день. Есть таблица без заголовков, нужно все столбцы в таблице выстроить в один столбец, ставя под крайний левый - второй слева и тд.
в итоге получится крайний левый столбец сверху, крайний правый снизу. Столбцы все разной высоты.
файл прикладываю, файл это часть оригинала, в оригинале больше 10к столбцов.  
Изменено: Robot attach you - 28.09.2020 09:30:17
 
Цитата
Robot attach you написал:
друг на друга
или все таки друг под другом?
покажите в файле исходные данные и рядом желаемый результат
Не бойтесь совершенства. Вам его не достичь.
 
Рискуете вылезти за ограничения, если в столбцах могут быть сотни строк.
 
Цитата
Robot attach you написал:
в оригинале больше 10к столбцов.  
Значит формулы не подойдут, только макрос.
А по высоте они поместятся?
 
Robot attach you,
Код
Sub Макрос1()
Dim lr As Long, col As Long, lcol As Long, celdel As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
For col = 2 To lcol
If Cells(2, col) <> "пусто_удалить" Then
lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
If Application.WorksheetFunction.CountA(Columns(col)) > 2 Then
    Range(Cells(2, col), Cells(2, col).End(xlDown)).Copy Destination:=Cells(lr, 1)
Else
     Cells(2, col).Copy Destination:=Cells(lr, 1)
End If
End If
Next col
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Не бойтесь совершенства. Вам его не достичь.
 
Ещё как вариант:
Код
Sub t()
x = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
x2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
y = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To y
    ActiveSheet.Range("B1:B" & x).Copy
    Range("A" & x2).Select
    ActiveSheet.Paste
    ActiveSheet.Columns(2).Delete Shift:=xlToLeft
    x = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    x2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
End Sub
 
Цитата
Mershik написал:
или все таки друг под другом?
да, друг под другом, файл прикладываю, там 2 листа, как есть  и как надо
Изменено: Robot attach you - 28.09.2020 11:35:54
 
Цитата
Robot attach you написал:
файл прикладываю
А зачем на форуме 2 файла, один из которых "плохой"?
 
Robot attach you, макрос проверяли из #5? но так как можно_удалить вы оставляете берите #6
или так
Код
Sub Ìàêðîñ1()
Dim lr As Long, col As Long, lcol As Long, celdel As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
For col = 2 To lcol
lr = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Range(Cells(1, col), Cells(1, col).End(xlDown)).Copy Destination:=Cells(lr, 1)
Next col
Range("B1", Cells(100000, lcol)).Clear
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 28.09.2020 11:49:31
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
GRIM написал:
Ещё как вариант:
Съело всю память, считало примерно пол часа, потом память кончилась. Не может закончить.
 
Код
Sub мяу()
    Dim ar, ar1
    With Sheets(1)
        ar = .Columns(1).Value
        k = .Cells(.Rows.Count, 1).End(xlUp).Row
        For j = 2 To .UsedRange.Columns.Count
            ar1 = .Range(.Cells(1, j), .Cells(.Rows.Count, j).End(xlUp)).Value
            For i = 1 To UBound(ar1)
                k = k + 1
                ar(k, 1) = ar1(i, 1)
            Next
        Next
    End With
    Sheets(2).Cells(1).Resize(k).Value = ar
End Sub
 
Robot attach you, сообщите, время выполнения (заголовок финального сообщения) на реальных данных
Код
Финальное сообщение
Изменено: Jack Famous - 30.09.2020 11:39:08
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Mershik написал:
Robot attach you , макрос проверяли из #5? но так как можно_удалить вы оставляете берите #6или так

Так сработало, спасибо, по времени около 4-5 минут!

Цитата
Jack Famous написал:
Robot attach you , сообщите, время выполнения (заголовок финального сообщения) на реальных данных

94082 ячейки, 0,67 сек., это лучший результат, спасибо !!!
 
Robot attach you, отлично) пожалуйста  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх