Страницы: 1
RSS
Разбить таблицу на блоки, по 6 строк.
 
Разбить таблицу (200 строк, 4 столбца) на блоки, по 6 строк. Блок начинается со строки с минимальным значением в 4 столбце и "по возрастанию" в последующих строках блока. Главное - Значения в 4 столбце не должны повторяться в одном блоке.
 
В примере нужно было показать желаемый результат, т.к. из описания не всё понятно.
 
velmak  Такое интересное и легкое задание, а никто не хочет помогать. Сортировку не добавлял, в файле примере столбец 4 отсортирован. Словарь не стал делать в принципе и коллекции пойдут. Выгрузку сделал на активный лист, что легко можно поменять. Сделал как понял. Проверяйте.
Код
Sub enstaralfffg()
Dim Arr1, Tp1(1 To 4), i&, j&
Dim Col1 As New Collection, Col2 As New Collection, Col3 As New Collection
Arr1 = Cells(1).CurrentRegion
For i = 1 To UBound(Arr1)
    Tp1(1) = Arr1(i, 1): Tp1(2) = Arr1(i, 2): Tp1(3) = Arr1(i, 3): Tp1(4) = Arr1(i, 4)
    Col1.Add Tp1
Next: i = 0
Do While Col1.Count > 1
i = i + 1
If Col2.Count = 0 Then
    Col2.Add Col1(i): Col3.Add Col1(i): Col1.Remove (i): i = 0
Else
    If Col2.Count > 6 Then
    Set Col2 = Nothing: i = 0
    Else
If Col1(i)(4) > Col2(Col2.Count)(4) Then Col2.Add Col1(i): Col3.Add Col1(i): Col1.Remove (i): i = 0
    End If
End If
Loop: Col3.Add Col1(1)
For i = 1 To Col3.Count: For j = 1 To 4: Arr1(i, j) = Col3(i)(j): Next: Next
Range("G1").Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
End Sub
 
Евгений Смирнов - Спасибо! огромное. "как доктор прописал"

P.S.
Код
.. If Col2.Count > 5 Then...
- чуть "допилил". Теперь блоки по 6 строк. (было по 7)
 
velmak Не забывайте, что столбец 4  должен быть отсортирован, иначе неверно отработает. Да что-то я второпях не проверил какие блоки получаются

Там вообще лучше написать
Код
If Col2.Count = 6

Так даже понятнее будет

Изменено: Евгений Смирнов - 05.02.2022 11:08:04
Страницы: 1
Наверх