Копирование части диапазона с шагом

[valerij]

Всем, Добрый вечер!
Подскажите, правильно ли сделал?
Из диапазона d3:d1353, лист1, нужно скопировать [d3:d33] и вставить в d3 с шагом 44 во все, девять, листов, не нравится, что листы переключаются и долго.

Sub копирование()
Dim dIap As Long, iList As Byte: dIap = 3
For iList = 1 To 9
    Sheets(1).[e3:e33].Copy
        Sheets(iList).Select
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        If iList = 1 Then dIap = 47
       Do
        .Cells(dIap, 5).Select
            .ActiveSheet.Paste
            dIap = dIap + 44
        Loop While Not dIap > 1323: dIap = 3
            .CutCopyMode = False
            .EnableEvents = True
        .ScreenUpdating = True
    End With
Next
End Sub

Теперь быстро!!

[The_Prist]

Вот Вам еще вариант

Sub копирование()
    Dim rDiap As Range
    Dim li As Long, le As Long
    Application.EnableEvents = False: Application.ScreenUpdating = False
    Set rDiap = Sheets(1).Range("e3:e33")
    For le = 1 To 9
    With Sheets(le)
        For li = 0 To 1323 Step 44
            rDiap.Copy .Range(rDiap.Offset(li).Address)
        Next li
    End With
    Next le
    Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

[Teslenko_EA]

Здравствуйте valerij.
не тестировал, но думаю будет быстрее

Sub копирование2()
Dim i%, j%
Sheets(1).[e3:e33].Copy
With Application
    .ScreenUpdating = False
    For j = 1 To 9
        For i = 3 To 1323 Step 44
            Sheets(j).Cells(i, 5).PasteSpecial Paste:=xlPasteAll
        Next
    Next
    .ScreenUpdating = True
End With
End Sub

Евгений.

[valerij]

Сообщение от The_Prist

Вот Вам еще вариант

ОК!!!!!!!!
Спасибо!!!
Женя, сейчас проверю!!
Ошибка, причем указывает, сюда, это макрос книги
If Not Intersect(Target, .Cells) Is Nothing Then

[valerij]

Женя, была ошибка, исправил(красным), синим-добавил, все стало ОК!
Скорость исполнения у всех, троих ~ =, но у The_Prist и у меня, после выполнения макроса отсутствует выделение и курсор там где и был, выделение снял, но остался выбор диапазона в конце [e1323:e13553] в каждом листе, т. е. курсор, если в начале исполнения макроса, был в [a1], то после перемещается на [e1323:e13553]

Sub копирование2()
Dim i%, j%, p%: p = 3
Sheets(1).[e3:e33].Copy
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    For j = 1 To 9
        If j = 1 Then p = 47
        For i = p To 1323 Step 44
            Sheets(j).Cells(i, 5).PasteSpecial Paste:=xlPasteAll
        Next: p = 3
    Next
     .CutCopyMode = False
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

В общем, СПАСИБО!!!

[Teslenko_EA]

Здравствуйте valerij.
"Скорость исполнения ... ~ =", слишком субъективная оценка, не приемлема для анализа, рекомендую использовать более точный "инструмент":

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub testProcedure()
Dim q&
q = timeGetTime
    'body test
Debug.Print timeGetTime - q
End Sub

Евгений.