Упростить код?

[aks_sv]

Подскажите, как упростить?

Код: Выделить всё

Sub CopyData()
Dim LastRow As Long, r As Long
Dim List As Worksheet
LastRow = Worksheets("Лист1").Range("A65536").End(xlUp).Row
For r = 1 To LastRow Step 4
s = (r +1) / 2
Set List= Worksheets("Лист1")
With Worksheets("Лист2")
    .Cells(s, 1).Value = List.Cells(r, 1).Value
    .Cells(s, 2).Value = List.Cells(r, 2).Value
    .Cells(s, 3).Value = List.Cells(r, 3).Value
    .Cells(s, 4).Value = List.Cells(r, 4).Value
    .Cells(s, 5).Value = List.Cells(r, 5).Value
    .Cells(s, 6).Value = List.Cells(r, 6).Value
    .Cells(s, 7).Value = List.Cells(r, 7).Value
    .Cells(s, 8).Value = List.Cells(r, 8).Value
    .Cells(s, 9).Value = List.Cells(r, 9).Value
    .Cells(s, 10).Value = List.Cells(r, 10).Value
    .Cells(s, 11).Value = List.Cells(r, 11).Value
    .Cells(s, 12).Value = List.Cells(r, 12).Value
    .Cells(s, 13).Value = List.Cells(r, 13).Value
    .Cells(s, 14).Value = List.Cells(r, 14).Value
    .Cells(s, 15).Value = List.Cells(r, 15).Value
    .Cells(s, 16).Value = List.Cells(r, 16).Value
    .Cells(s + 1, 1).Value = List.Cells(r + 1, 1).Value
    .Cells(s + 1, 2).Value = List.Cells(r + 1, 2).Value
    .Cells(s + 1, 3).Value = List.Cells(r + 1, 3).Value
    .Cells(s + 1, 4).Value = List.Cells(r + 1, 4).Value
    .Cells(s + 1, 5).Value = List.Cells(r + 1, 5).Value
    .Cells(s + 1, 6).Value = List.Cells(r + 1, 6).Value
    .Cells(s + 1, 7).Value = List.Cells(r + 1, 7).Value
    .Cells(s + 1, 8).Value = List.Cells(r + 1, 8).Value
    .Cells(s + 1, 9).Value = List.Cells(r + 1, 9).Value
    .Cells(s + 1, 10).Value = List.Cells(r + 1, 10).Value
    .Cells(s + 1, 11).Value = List.Cells(r + 1, 11).Value
    .Cells(s + 1, 12).Value = List.Cells(r + 1, 12).Value
    .Cells(s + 1, 13).Value = List.Cells(r + 1, 13).Value
    .Cells(s + 1, 14).Value = List.Cells(r + 1, 14).Value
    .Cells(s + 1, 15).Value = List.Cells(r + 1, 15).Value
    .Cells(s + 1, 16).Value = List.Cells(r + 1, 16).Value
End With
Next r
End Sub

[mc-black]

Циклом, например так:

Код: Выделить всё

Sub CopyData()
Dim LastRow As Long, r As Long, i As Long
    Dim List As Worksheet
    LastRow = Worksheets("Лист1").Range("A65536").End(xlUp).Row
    Set List= Worksheets("Лист1")
    For r = 1 To LastRow Step 4
        s = (r +1) / 2
        With Worksheets("Лист2")
        For i = 1 To 16
            .Cells(s, i).Value = List.Cells(r, i).Value
        Next i
        End With
    Next r
    Set List = Nothing
End Sub

Можно наверное еще чем-то упростить, я не вникал особо... Не забывайте Set выносить за цикл и не забывайте после работы с экземпляром объекта его уничтожать (Set List = Nothing)

[somewhere]

Поправлю

Код: Выделить всё

        For i = 1 To 16
            .Cells(s, i).Value = List.Cells(r, i).Value
            .Cells(s+1, i).Value = List.Cells(r+1, i).Value
        Next i

И еще кажется можно копировать весь диапазон, через Range как то

[aks_sv]

ВСЕМ Спасибо

[Aent]

Именно,somewhere

Код: Выделить всё

...
.Cells(s,1).Resize(2,16).copy list.cells(r,1)
...

[aks_sv]

Aent,
Самый лучший вариант, спасибо. Только копировать Листа1 на Лист2.