Необходимо зациклить Копировать каждую строку определенное количество раз на основе значения ячейки - PullRequest
0 голосов
/ 21 февраля 2019

У меня есть следующий код, который я использую для циклического перемещения по листу.Каждая строка должна быть скопирована определенное количество раз, а новые строки вставлены внизу, после последней строки, в которой в настоящий момент есть какой-либо текст.Количество строк для копирования для каждой существующей строки находится в ячейке для столбца BU этой строки.Следовательно, для этого я создал следующий цикл для перемещения по каждой строке и использования значения ячейки в столбце BU, чтобы скопировать ячейки в столбцах с A по BT, а затем вставить после последней активной видимой строки.Тем не менее, это не работает хорошо.

Есть мысли?

Sub Transfer()
Application.ScreenUpdating = False

Dim lastrow As Long, lngRows
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1

Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rowCount As Long

Set wsSource = Worksheets("Forecasted Movement")
With wsSource
rowCount = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- modifed this line

On Error Resume Next
For i = 2 To rowCount
    If .Cells(i, "BU").Value > 0 Then

        lngRows = .Cells(i, "BU").Value

       Range(Cells(i, 1), Cells(i, 72)).specialcells(xlCellTypeVisible).Copy

        wsSource.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues



    End If
Next i
End With

Application.ScreenUpdating = True

End Sub

1 Ответ

0 голосов
/ 21 февраля 2019

Если это все на одном листе (как подсказывает код), то ваша проблема - ваша последняя проблема.Вы должны пересчитывать его каждый раз, когда вставляете новую строку.

Sub Transfer()
Application.ScreenUpdating = False

Dim lastrow As Long, lngRows


Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rowCount As Long

Set wsSource = Worksheets("Forecasted Movement")
With wsSource
rowCount = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- modifed this line

On Error Resume Next
For i = 2 To rowCount
    If .Cells(i, "BU").Value > 0 Then

        lngRows = .Cells(i, "BU").Value

       Range(Cells(i, 1), Cells(i, 72)).specialcells(xlCellTypeVisible).Copy
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1  ' recalculate this for the next blank row
        wsSource.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues



    End If
Next i
End With

Application.ScreenUpdating = True

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...