Excel 在当前行下复制每行20次

我试图将Excel电子表格中的每一行复制20次

我试着写一个脚本，结果如下

---

像这样的事情应该使它相对容易和快速

Sub AddCols()
    Dim howMany As Integer: howMany = Application.InputBox(prompt:="Enter number of rows to add", title:="Bulk Add Rows", type:=1)
    Dim prods As New Collection
    Dim lrow As Long: lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False

    Dim tRange As Range
    For Each tRange In ActiveSheet.Range("A2:A" & lrow)
        'Add pointer to cell address-this way it'll adapt while we insert rows
        If Len(tRange.Value) > 0 Then prods.Add tRange
    Next
    Set tRange = Nothing

    Dim prod As Variant
    For Each prod In prods
        ActiveSheet.Range(prod.Address).EntireRow.Resize(howMany).Insert
    Next prod
    Set prod = Nothing

    ActiveSheet.Range("A2:M" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).Select

    For Each prod In Selection
        prod.Value = prod.Offset(-1).Value
    Next

    Application.ScreenUpdating = True
End Sub

---

简单的手动方式：填写数据旁边的数字1到638。复制整个数据集，包括新列，在数据下面粘贴19次，然后在最后一个数字列上排序。genius..我必须阅读5次才能得到它…所以基本上我将所有数据复制19次到它下面。。。（复制/粘贴19次）然后在全部选中后单击“排序”。哈哈。将鼠标移到“我的评论”的左侧，您会看到出现一个灰色的向上箭头-单击它。：）如果@Rory的建议有效，您可以自动复制/粘贴19次。打开宏录制器，然后执行一次或两次。然后，您可以检查代码，并尝试让它循环多少次。你从哪里得到你的密码的？这有点奇怪，但很有效，所以我很好奇。stackoverflow.com/questions/21912445/…–user2769025谢谢，我会试试。如果某个解决方案对您有效，请将其标记为答案（如果已作为答案提供）。如果没有人建议，那么请确保自己将其作为答案发布。完成，答案已标记，我无法用复制/手动方式标记其他答案。

Sub AddCols()
    Dim howMany As Integer: howMany = Application.InputBox(prompt:="Enter number of rows to add", title:="Bulk Add Rows", type:=1)
    Dim prods As New Collection
    Dim lrow As Long: lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False

    Dim tRange As Range
    For Each tRange In ActiveSheet.Range("A2:A" & lrow)
        'Add pointer to cell address-this way it'll adapt while we insert rows
        If Len(tRange.Value) > 0 Then prods.Add tRange
    Next
    Set tRange = Nothing

    Dim prod As Variant
    For Each prod In prods
        ActiveSheet.Range(prod.Address).EntireRow.Resize(howMany).Insert
    Next prod
    Set prod = Nothing

    ActiveSheet.Range("A2:M" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).Select

    For Each prod In Selection
        prod.Value = prod.Offset(-1).Value
    Next

    Application.ScreenUpdating = True
End Sub