Проблема с циклами в процессе копирования

[Посетитель]

Пытаюсь из перечня значений в столбце А (заполнены все строки без пропусков) перенести все заначения по порядку но через интервал в 5 строк. Не понимаю как настроить циклы чтобы значения брались только по одному разу, в итоге приведенного ниже кода получаю текст через каждые 5 строк, но в каждой ячейке значение из последней строки в диапазоне.
помогите пожалуйста разобраться как это пофиксить


Sub копирование()
Dim i As Long
Dim j As Long
  For i = 1 To 2
  For j = 1 To i * 5 Step 5
    Worksheets("Лист1").Cells(i, 1).Copy (Worksheets("Лист1").Cells(j, 2))
  Next
  Next
End Sub

[Администратор]

Создайте файл-пример с двумя листами.
На одном листе исходные данные.
На втором листе данные после макроса.
И поясните на основе этих двух листов принцип.

[Посетитель]

первый лист - до макроса, второй - после

[ФАЙЛЫ ВАШИ ПОЛУЧЕНЫ - НЕТ НЕОБХОДИМОСТИ ВЫКЛАДЫВАТЬ ИХ ПОВТОРНО]

[Администратор]

Вы неправильно меня поняли.
Вам надо предоставить лист "после", в котором данные расположены правильно. Т.е. это вам надо сделать вручную.
Не обязательно делать пример для всех строк, достаточно для нескольких, чтобы стал понятен принцип.

[Посетитель]

понял, теперь как просили сформировал

[ФАЙЛЫ ВАШИ ПОЛУЧЕНЫ - НЕТ НЕОБХОДИМОСТИ ВЫКЛАДЫВАТЬ ИХ ПОВТОРНО]

[Администратор]

Написал вам два письма на почту с заголовком "Письмо с Форума по VBA, Excel и Word". Написал именно на почту, а не на форум.

Макрос

Sub Копирование()
   
    Dim Worksheet As Worksheet
    Dim Lr As Long, r As Long, i As Long
   
   
    ' Создание ссылки на лист, с которым надо работать.
    Set Worksheet = Worksheets("Лист1")
   
    ' Поиск последней строки.
        ' End не видит скрытые строки.
    Lr = Worksheet.Cells(Worksheet.Rows.Count, "A").End(xlUp).Row
   
    ' Расстановка значений.
    r = 1
    For i = 1 To Lr
        Worksheet.Cells(r, "B").Value = Worksheet.Cells(i, "A").Value
        r = r + 5
    Next i
   
End Sub

[свернуть]