Доброго времени суток. Бьюсь с проблемой. Нужно перенести каждые 6 строк из столбца B на вкладке "Данные" и копировать данные из столбца С с транспонированием на вкладку "Сводник". Данные разделены единицой. Никак не получается сделать толковую петлю, которая бы прошлась по всему диапазону. Буду признателен за любую помощь.
Доброго времени суток. Бьюсь с проблемой. Нужно перенести каждые 6 строк из столбца B на вкладке "Данные" и копировать данные из столбца С с транспонированием на вкладку "Сводник". Данные разделены единицой. Никак не получается сделать толковую петлю, которая бы прошлась по всему диапазону. Буду признателен за любую помощь.thrasher
Если кол-во строк не меняется и разделитель всегда 1, то: [vba]
Код
Sub cpy() Dim x Dim arResult(1 To 1000000, 1 To 6) Dim r&, i&, v As Byte, z As Byte x = Sheets("Данные").Range("B4:C" & Sheets("Данные").[b1000000].End(xlUp).Row).Value i = 0 For r = 1 To UBound(x) If x(r, 1) = 1 Then i = i + 1 z = 0 For v = 1 To 6 arResult(i, v) = x(r + z, 2) z = z + 1 Next End If Next Sheets("Сводник").[b2].Resize(i, 6) = arResult End Sub
[/vba]
Если кол-во строк не меняется и разделитель всегда 1, то: [vba]
Код
Sub cpy() Dim x Dim arResult(1 To 1000000, 1 To 6) Dim r&, i&, v As Byte, z As Byte x = Sheets("Данные").Range("B4:C" & Sheets("Данные").[b1000000].End(xlUp).Row).Value i = 0 For r = 1 To UBound(x) If x(r, 1) = 1 Then i = i + 1 z = 0 For v = 1 To 6 arResult(i, v) = x(r + z, 2) z = z + 1 Next End If Next Sheets("Сводник").[b2].Resize(i, 6) = arResult End Sub
Sub qq() With CreateObject("scripting.dictionary") For i = 5 To Sheets("Данные").Cells(Rows.Count, 2).End(xlUp).Row - 1 Step 6 .Item(i) = Application.Transpose(Sheets("Данные").Range("C" & i & ":C" & i + 4).Value) Next arr = Application.Transpose(Application.Transpose(.items)) Sheets("Сводник Итог").Range("B4").Resize(.Count, 5) = arr End With End Sub
[/vba]
Во придумал! Сам себе удивляюсь!
[vba]
Код
Sub qq() With CreateObject("scripting.dictionary") For i = 5 To Sheets("Данные").Cells(Rows.Count, 2).End(xlUp).Row - 1 Step 6 .Item(i) = Application.Transpose(Sheets("Данные").Range("C" & i & ":C" & i + 4).Value) Next arr = Application.Transpose(Application.Transpose(.items)) Sheets("Сводник Итог").Range("B4").Resize(.Count, 5) = arr End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
