Question

我有以下代码可用于遍历工作表。每行需要复制一定的次数，并将新行粘贴到当前有任何文本的最后一行之后的底部。每个当前行要复制的行数在该行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

Answer 1

如果这一切都在同一工作表中（如代码所示），则您的最后一题就是您的问题。每次粘贴新行时都需要重新计算。

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

需要根据单元格值循环复制每行一定次数

1 个答案: