Существует ли способ быстрого объединения таблиц в одну, последовательно? 1. Таблицы не имеют шапки 2. Таблицы по 100 строк и 6 столбцов. 3. Таблицы расположены на одном листе, друг за дружкой. Таблиц таких может быть до 45 штук
Данные не должны перемешаться, объединиться или как-то ещё измениться. Нужно просто расположить их вертикально друг за дружкой без разрыва, по сути сделать одну длинную таблицу.
В оригинале стобцы в таблицах-исходниках никак не подсвечены и не названы, в файле-примере я для удобства восприятия их покрасил. В файле-примере лист1 - это то, что есть, лист2 - то, что должно получиться.
откройте лист ДО нажмите Alt+F8 выберите TransformateNx6to1x6 нажмите Выполнить (внимание!!! повторное выполнение TransformateNx6to1x6 приведет к повторному дополнению таблиц в первые 6 колонок)
Код
Sub TransformateNx6to1x6()
Dim i&: i = 1
Do While Not IsEmpty(Cells(1, i * 6 + 1))
Range(Cells(1, (i + 1) * 6), Cells(Rows.Count, i * 6 + 1).End(xlUp)).Copy _
Cells(Rows.Count, 1).End(xlUp).Offset(1)
i = i + 1
Loop
End Sub
Roman911, принцип тот же, что и раньше (создание нового листа и вставка на него), скорость тоже отличная (0,02 - 0,03 сек)
Кода больше, чем у Игоря
Код
Option Explicit
'===========================================================================================
Sub MergeColumns()
Dim x, arr, arrNew(), nGr#, t!, rNew&, cNew&, rOld&, cOld&, gr As Byte
Const colStep = 6 'сколько столбцов в каждой группе (задаётся вручную тут в коде)
t = Timer
arr = ActiveSheet.UsedRange.Value2
If Not IsArray(arr) Then Exit Sub
nGr = UBound(arr, 2) / colStep ' количество ГРУПП столбцов
If nGr <> Fix(nGr) Then MsgBox "Количество столбцов «" & UBound(arr, 2) & "» рабочей области листа должно быть КРАТНО количеству столбцов одной группы«" & colStep & "»", vbCritical, "ОШИБКА АЛГОРИТМА": Exit Sub
ReDim arrNew(1 To nGr * UBound(arr, 1), 1 To colStep)
For gr = 1 To nGr
cOld = (gr - 1) * colStep
For rOld = 1 To UBound(arr, 1)
rNew = rNew + 1
For cNew = 1 To UBound(arrNew, 2)
arrNew(rNew, cNew) = arr(rOld, cOld + cNew)
Next cNew
Next rOld
Next gr
Application.ScreenUpdating = False
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(UBound(arrNew, 1), UBound(arrNew, 2)).Value2 = arrNew
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "Время работы: " & Format$(1000 * (Timer - t), "0 мс"), vbInformation, "ГОТОВО"
End Sub
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
торопился вчера и не заметил, что у Игоря это в коде это тоже легко регулируется. Более того, если тот же код сделать на массивах, то он не будет уступать в скорости моему варианту, хотя, думаю, что на ваших объёмах и так всё отилчно
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую. Прошу помощи. Создал сводную таблицу из данный с нескольких листов. Необходимо чтоб сводная таблица, считала согласно фильтра месяц (колонка В) сумму отработанных часов (колонка К) водителя на автом. Но таблица считает количество раз упомянутых фамилий на автом.
Jack Famous, спасибо, я просто понял, зачем это всё нужно (новая тема и название) и постарался сделать так, чтобы форум получил максимальный эффект На моих объёмах да, всё идеально. Первый раз когда совсем всё в ручную делалось я понял, что на за полчаса обработаю только 9000 строк. Сейчас 111 000 строк )
по идее, даже увеличение объёмов в сотни раз при сохранении логики не должно быть сильно медленнее (для моего макроса, т.к. у Игоря вариант на работе с ячейками по отдельности, а это будет долго на больших объёмах). Если будут проблемы, то пишите сюда
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄