Добрый день. Есть таблица без заголовков, нужно все столбцы в таблице выстроить в один столбец, ставя под крайний левый - второй слева и тд. в итоге получится крайний левый столбец сверху, крайний правый снизу. Столбцы все разной высоты. файл прикладываю, файл это часть оригинала, в оригинале больше 10к столбцов.
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
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
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, сообщите, время выполнения (заголовок финального сообщения) на реальных данных
Код
Код
Option Explicit
'====================================================================================================
Sub ReDesign()
Dim rng As Range
Dim arr, arrOut(), r&, c&, n&, t!
t = Timer
' выбрать ОДИН, остальные закомментировать
'Set rng = Selection ' для выделенного диапазона
Set rng = ActiveSheet.UsedRange ' для всей рабочей области листа
'Set rng = Range("A1:I25") ' задать диапазон в коде
'Set rng = Range("MyRange") ' именованый диапазон
Set rng = Intersect(rng, ActiveSheet.UsedRange)
If rng Is Nothing Then MsgBox "Диапазоне не определён!", vbExclamation, "ОШИБКА ДИАПАЗОНА": Exit Sub
If rng.Areas.Count <> 1 Then MsgBox "Не более ОДНОЙ области!", vbExclamation, "ОШИБКА ДИАПАЗОНА": Exit Sub
arr = rng.Value2
ReDim arrOut(1 To rng.Cells.Count, 1 To 1)
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If Len(arr(r, c)) Then n = n + 1: arrOut(n, 1) = arr(r, c)
Next r
Next c
If n = 0 Then MsgBox "Данных не найдено!", vbExclamation, "ОШИБКА ДИАПАЗОНА": Exit Sub
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(n, 1).Value2 = arrOut
MsgBox "Успешно выгружено ячеек: " & Format(n, "# ### ### ##0"), vbInformation, Format(Timer - t, "0.00 сек")
End Sub
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄