Добрый день! Столбцы с 5 000 строками. Надо что бы я мог задавать настройку по разбивке число строк и они разбивались. Пример разбивки по 20 строк указан справа. Надо что бы я могу указывать число строк по своему усмотрению.
Добрый день! Столбцы с 5 000 строками. Надо что бы я мог задавать настройку по разбивке число строк и они разбивались. Пример разбивки по 20 строк указан справа. Надо что бы я могу указывать число строк по своему усмотрению.kaiyrkz0
Sub u_759() Application.ScreenUpdating = False x = Cells(1, Columns.Count).End(xlUp).Column y = Cells(Rows.Count, "g").End(xlUp).Row If x > 2 Then Range(Cells(1, 7), Cells(y, x)).Clear u = InputBox("Ââåñòè Êîë-âî ñòðîê") a = Cells(Rows.Count, "a").End(xlUp).Row If IsNumeric(u) Then b = Application.Round(a / u + 0.5, 0) For c = 1 To b Range("a" & (c - 1) * u + 1 & ":b" & c * u).Copy Cells(1, c * 2 + 5) Next End If Application.ScreenUpdating = True End Sub
[/vba]
[vba]
Код
Sub u_759() Application.ScreenUpdating = False x = Cells(1, Columns.Count).End(xlUp).Column y = Cells(Rows.Count, "g").End(xlUp).Row If x > 2 Then Range(Cells(1, 7), Cells(y, x)).Clear u = InputBox("Ââåñòè Êîë-âî ñòðîê") a = Cells(Rows.Count, "a").End(xlUp).Row If IsNumeric(u) Then b = Application.Round(a / u + 0.5, 0) For c = 1 To b Range("a" & (c - 1) * u + 1 & ":b" & c * u).Copy Cells(1, c * 2 + 5) Next End If Application.ScreenUpdating = True End Sub
Sub Разделить() Dim arr1, arr2, n As Long, m As Long, i As Long m = InputBox("Ввести кол-во строк") n = Cells(Rows.Count, "A").End(xlUp).Row arr1 = Range(Cells(1, 1), Cells(n, 2)) i = IIf(n Mod m > 0, Fix(n / m) * 2 + 2, Fix(n / m) * 2) ReDim arr2(1 To m, 1 To i) n = 1: m = 1 For i = 1 To UBound(arr1) arr2(n, m) = arr1(i, 1) arr2(n, m + 1) = arr1(i, 2) If n = UBound(arr2) Then n = 1: m = m + 2 Else n = n + 1 Next With Worksheets("Лист2") .Cells.Clear .Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2 .Activate End With End Sub
[/vba]
Ещё Вариант, результат на Лист2 [vba]
Код
Sub Разделить() Dim arr1, arr2, n As Long, m As Long, i As Long m = InputBox("Ввести кол-во строк") n = Cells(Rows.Count, "A").End(xlUp).Row arr1 = Range(Cells(1, 1), Cells(n, 2)) i = IIf(n Mod m > 0, Fix(n / m) * 2 + 2, Fix(n / m) * 2) ReDim arr2(1 To m, 1 To i) n = 1: m = 1 For i = 1 To UBound(arr1) arr2(n, m) = arr1(i, 1) arr2(n, m + 1) = arr1(i, 2) If n = UBound(arr2) Then n = 1: m = m + 2 Else n = n + 1 Next With Worksheets("Лист2") .Cells.Clear .Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2 .Activate End With End Sub
Sub u_759() Application.ScreenUpdating = False x = Cells(1, Columns.Count).End(xlUp).Column y = Cells(Rows.Count, "g").End(xlUp).Row If x > 2 Then Range(Cells(1, 7), Cells(y, x)).Clear u = InputBox("Ввести Кол-во строк") a = Cells(Rows.Count, "a").End(xlUp).Row If IsNumeric(u) Then b = Application.Round(a / u + 0.5, 0) For c = 1 To b Range("a" & (c - 1) * u + 1 & ":c" & c * u).Copy Cells(1, c * 3 + 4) Next End If Application.ScreenUpdating = True End Sub
[/vba] Range("a" & (c - 1) * u + 1 & ":c" & c * u).Copy Cells(1, c * 3 + 4)
[vba]
Код
Sub u_759() Application.ScreenUpdating = False x = Cells(1, Columns.Count).End(xlUp).Column y = Cells(Rows.Count, "g").End(xlUp).Row If x > 2 Then Range(Cells(1, 7), Cells(y, x)).Clear u = InputBox("Ввести Кол-во строк") a = Cells(Rows.Count, "a").End(xlUp).Row If IsNumeric(u) Then b = Application.Round(a / u + 0.5, 0) For c = 1 To b Range("a" & (c - 1) * u + 1 & ":c" & c * u).Copy Cells(1, c * 3 + 4) Next End If Application.ScreenUpdating = True End Sub
[/vba] Range("a" & (c - 1) * u + 1 & ":c" & c * u).Copy Cells(1, c * 3 + 4)Nic70y
ЮMoney 41001841029809
Сообщение отредактировал Nic70y - Среда, 27.09.2023, 12:50
Nic70y, Как сделать что бы распределял четыре столбца: номер, имя, число, пустая ячейка? или что бы запрашивал сколько столбцов брать как в случае со строками. Большое спасибо.
Nic70y, Как сделать что бы распределял четыре столбца: номер, имя, число, пустая ячейка? или что бы запрашивал сколько столбцов брать как в случае со строками. Большое спасибо.kaiyrkz0
Сообщение отредактировал kaiyrkz0 - Пятница, 27.10.2023, 13:21
Уже не помню, что я там писал, но попробуйте так, вставляйте сколько нужно столбцов [vba]
Код
Sub Разделить() Dim arr1, arr2, n As Long, m As Long, i As Long k = InputBox("Ввести кол-во столбцов в таблице") m = InputBox("Ввести кол-во строк") n = Cells(Rows.Count, "A").End(xlUp).Row arr1 = Range(Cells(1, 1), Cells(n, CInt(k))) i = IIf(n Mod m > 0, Fix(n / m) * k + k, Fix(n / m) * k) ReDim arr2(1 To m, 1 To i) n = 1: m = 1 For i = 1 To UBound(arr1) For v = 1 To k arr2(n, m + v - 1) = arr1(i, v) Next If n = UBound(arr2) Then n = 1: m = m + k Else n = n + 1 Next With Worksheets("Лист2") .Cells.Clear .Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2 .Activate End With End Sub
[/vba] PS подправил код
Уже не помню, что я там писал, но попробуйте так, вставляйте сколько нужно столбцов [vba]
Код
Sub Разделить() Dim arr1, arr2, n As Long, m As Long, i As Long k = InputBox("Ввести кол-во столбцов в таблице") m = InputBox("Ввести кол-во строк") n = Cells(Rows.Count, "A").End(xlUp).Row arr1 = Range(Cells(1, 1), Cells(n, CInt(k))) i = IIf(n Mod m > 0, Fix(n / m) * k + k, Fix(n / m) * k) ReDim arr2(1 To m, 1 To i) n = 1: m = 1 For i = 1 To UBound(arr1) For v = 1 To k arr2(n, m + v - 1) = arr1(i, v) Next If n = UBound(arr2) Then n = 1: m = m + k Else n = n + 1 Next With Worksheets("Лист2") .Cells.Clear .Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2 .Activate End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
