Это будет l oop по вашему листу до последней использованной строки, начиная с 7-й строки и шагая по 7-ти строкам в каждой итерации.
В каждой итерации каждая ячейка строки записывается в массив, который затем записывается на другой лист, готовый к сортировке (как бы вы этого не хотели).
Этот код является примером и может не работать при копировании / вставке.
- Я написал это в модуле кода
Sheet1, поэтому Me относится к ThisWorkbook.Sheets("Sheet1"). - Я сделал это из пустой книги и не переименовал никакие листы, поэтому вам нужно будет внести изменения в любые ссылки на листы, чтобы они соответствовали вашим соответствующим именам листов.
- Код будет ссылаться только на столбцы A, B и C в
TargetRow (я тестировал только 3 столбца данных, поскольку не знаю ваш рабочий диапазон). Я буду ссылаться на то, что обновить, чтобы расширить это после блока кода. - В настоящее время массив помещается обратно в
Sheet2, начиная с ячейки A2. Предполагается, что строка 1 содержит заголовки таблиц, поскольку эти данные будут записываться непосредственно в формат таблицы. Естественно, если вы хотите изменить место записи данных, измените ячейку, в которую они записаны (при записи массива на лист вам нужно определить только верхнюю левую ячейку диапазона, в который они записаны, Excel работает на основе остальных размер и размеры массива).
Sub WriteEverySeventhRowToAnotherSheet()
Dim SeventhRowCount As Long
Dim myArray() As Variant
Dim lastrow As Long
Dim TargetCell As Variant
Dim TargetRow As Range
Dim ArrFirstDimension As Long
Dim ArrSecondDimension As Long
lastrow = Me.Range("A" & Me.Rows.Count).End(xlUp).Row
ReDim myArray(1 To lastrow / 7, 1 To 3)
ArrFirstDimension = 1
ArrSecondDimension = 1
'------------------Loop over every 7th row and enter row data to array---------------
For SeventhRowCount = 7 To lastrow Step 7
Set TargetRow = Me.Range("A" & SeventhRowCount & ":C" & SeventhRowCount)
For Each TargetCell In TargetRow
If Not ArrSecondDimension > UBound(myArray) Then
myArray(ArrFirstDimension, ArrSecondDimension) = TargetCell
'Debug.Print TargetCell
ArrSecondDimension = ArrSecondDimension + 1
End If
Next TargetCell
ArrFirstDimension = ArrFirstDimension + 1
ArrSecondDimension = 1
Set TargetRow = Nothing
Next SeventhRowCount
'---------------------Write array to another sheet------------------
Dim Destination As Range
Set Destination = ThisWorkbook.Sheets("Sheet2").Range("A2")
Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
Чтобы увеличить число столбцов, которые l oop запишет в массив, измените следующий экземпляр C на правильную букву столбца (в строке ниже диапазон устанавливается от столбца A к столбцу C):
Set TargetRow = Me.Range("A" & SeventhRowCount & ":C" & SeventhRowCount)
Также измените 2-е измерение массива, чтобы соответствовать номеру указанного выше столбца (т. е. столбец E = 5 и столбец L = 13 и т. д. c.) - необходимо заменить число 3 на правильное число.
ReDim myArray(1 To lastrow / 7, 1 To 3)