Сори недосмотрел
Все равно предложу альтернативу
Дело в том, что ReDim Preserve arr(1 To 4, 1 To h) внутри цикла замедляет выполнение процедуры. Для быстродействия лучше вычислить размер итогового массива до цикла (конечно если это возможно), так будет быстрей работать, конечно при цикле в 491 строку и 4 поля это незаметно, но если запустить обработку скажем 900000 строк и 25 полей массива ReDim Preserve однозначно проявит себя.
Код |
---|
Option Explicit
Sub TempCopy11()
Dim arr(), arrItog()
Dim maxRow As Long, maxClmn As Long
Dim i As Long, x As Long, n As Long
With ThisWorkbook
''' Загрузка массива с шагом в 10 строк
arr = .Sheets("Лист1").Range(.Sheets("Лист1").Cells(1, 1).End(xlToRight), .Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp)).Value
maxRow = UBound(arr, 1): maxClmn = UBound(arr, 2)
ReDim arrItog(1 To maxRow / 10 + 1, 1 To maxClmn)
For i = 1 To maxRow Step 10
n = n + 1
For x = 1 To maxClmn
arrItog(n, x) = arr(i, x)
Next x
Next i
''' Выгрузка массива ответа в два разных места
With Sheets("Лист2")
.Range("A1").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
End With
On Error Resume Next
.Worksheets.Add.Name = "List12345"
With Sheets("List12345")
.Range("A1").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
End With
Erase arr: Erase arrItog
End With
End Sub
|