Перенос наименований n-ое количество раз

[Анастасия]

Здравствуйте! Помогите, пожалуйста, разобраться с проблемой.
В файле необходимо с листа 1 перенести на лист 2 наименования контрагентов, причем каждый к/а должен повториться 12 раз, т.к. в дальнейшем для каждого к/а будут указаны суммы на каждый месяц года (в столбцах 2 и 3). Проблема возникла в том, что когда начинаем переносить начиная со 2-го к/а (i) на лист 2, переносится только какой то один к/а, например, 2 или 3, или 4, а нужны все по очереди (как в таблице листа 1 по 12 раз). Также пыталась задать For i=2 To r1.Rows.Count, т.к. в реалии наименований к/а может быть сколько угодно, программа вообще зависает. Для переменной l тоже меняла формулу (чтобы с 14 по 25 стоял 2 к/а, с 26 по 37 - 3 к/а и т.д.), получается ерунда.

[вложение удалено администратором]

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

Макрос

Private Sub cmd1_Click()

    Dim shSrc As Excel.Worksheet, shRes As Excel.Worksheet
    Dim arrSrc() As Variant, arrRes(1 To 12, 1 To 1) As Variant
    Dim lngLRow As Long, i As Long, j As Long, r As Long
   
   
    '1. Отключение монитора, чтобы ускорить работу макроса.
    Application.ScreenUpdating = False
   
    '2. Vba-именование двух листов.
    Set shSrc = Worksheets("Лист1")
    Set shRes = Worksheets("Лист2")
   
    '3. Очистка листа от старых данных.
    shRes.UsedRange.EntireRow.Delete
   
    '4. Копирование данных их листа в массив - с массивыми макрос быстрее работает.
    ' Поиск последней строки.
    lngLRow = shSrc.Columns("A").Find(What:="?", LookIn:=xlFormulas, LookAt:=xlPart, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    ' Копирование.
    arrSrc() = shSrc.Range("A1:A" & lngLRow).Value
   
    '5.
    For i = 2 To UBound(arrSrc, 1) Step 1
        ' Сначала размножение КА в массив "arrRes".
        For j = 1 To 12 Step 1
            arrRes(j, 1) = arrSrc(i, 1)
        Next j
        ' Корректирвка переменной "r" (с помощью неё двигаемся по листу-результату).
            ' Корректируется, если это первый КА.
        If r = 0 Then
            r = r + 1
        End If
        ' Вставка данных на лист-результат.
        shRes.Cells(r, 1).Resize(12, 1).Value = arrRes()
        ' Корректировка переменной "r".
        r = r + 12
    Next i
   
    '6. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

[свернуть]