Здравствуйте! Помогите, пожалуйста, разобраться с проблемой.
В файле необходимо с листа 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