Excel VBA自动化 - 根据单元格值复制行“x”次数

Question

我正在尝试以一种可以节省无数小时繁琐数据输入的方式来自动化 Excel。 这是我的问题。

我们需要为所有库存打印条形码，其中包括 4,000 个变体，每个变体都有特定的数量。

Shopify 是我们的电子商务平台，不支持定制出口； 但是，可以导出所有变体的 CSV，其中包括库存计数列。

我们将 Dymo 用于我们的条码打印硬件/软件。 Dymo 每行只打印一个标签（它忽略数量列）。

有没有办法自动化 excel 以根据库存列中的值复制行“x”次数？

以下是数据示例：

https://www.evernote.com/shard/s187/sh/b0d5b92a-c5f6-469c-92fb-3d4e03d97544/d176d3448ba0cafbf3d61506402d9e8b/res/254447d2-486d-454f-8871-a0962f03253dsk/

• 如果 Column N = 0，忽略并移至下一行
• 如果列 N > 1，复制当前行，“N”次（到单独的工作表）

我试图找到做过类似事情的人，以便我可以修改代码，但经过一个小时的搜索，我仍然在我开始的地方。 预先感谢您的帮助！

Answer 1

大卫打败了我，但另一种方法从未伤害过任何人。

考虑以下数据

Item           Cost Code         Quantity
Fiddlesticks   0.8  22251554787  0
Woozles        1.96 54645641     3
Jarbles        200  158484       4
Yerzegerztits  56.7 494681818    1

有了这个功能

Public Sub CopyData()
    ' This routing will copy rows based on the quantity to a new sheet.
    Dim rngSinglecell As Range
    Dim rngQuantityCells As Range
    Dim intCount As Integer

    ' Set this for the range where the Quantity column exists. This works only if there are no empty cells
    Set rngQuantityCells = Range("D1", Range("D1").End(xlDown))

    For Each rngSinglecell In rngQuantityCells
        ' Check if this cell actually contains a number
        If IsNumeric(rngSinglecell.Value) Then
            ' Check if the number is greater than 0
            If rngSinglecell.Value > 0 Then
                ' Copy this row as many times as .value
                For intCount = 1 To rngSinglecell.Value
                    ' Copy the row into the next emtpy row in sheet2
                    Range(rngSinglecell.Address).EntireRow.Copy Destination:= Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)                                
                    ' The above line finds the next empty row.

                Next
            End If
        End If
    Next
End Sub

在 sheet2 上生成以下输出

Item            Cost    Code        Quantity
Woozles         1.96    54645641    3
Woozles         1.96    54645641    3
Woozles         1.96    54645641    3
Jarbles         200     158484      4
Jarbles         200     158484      4
Jarbles         200     158484      4
Jarbles         200     158484      4
Yerzegerztits   56.7    494681818   1

此代码的注意事项是数量列中不能有空字段。 我用了 D 所以随意用 N 代替你的情况。

Answer 2

应该足以让你开始：

Sub CopyRowsFromColumnN()

Dim rng As Range
Dim r As Range
Dim numberOfCopies As Integer
Dim n As Integer

'## Define a range to represent ALL the data
Set rng = Range("A1", Range("N1").End(xlDown))

'## Iterate each row in that data range
For Each r In rng.Rows
    '## Get the number of copies specified in column 14 ("N")
    numberOfCopies = r.Cells(1, 14).Value

    '## If that number > 1 then make copies on a new sheet
    If numberOfCopies > 1 Then
        '## Add a new sheet
        With Sheets.Add
            '## copy the row and paste repeatedly in this loop
            For n = 1 To numberOfCopies
                r.Copy .Range("A" & n)
            Next
        End With
    End If
Next

End Sub

Answer 3

回答可能有点晚，但这可以帮助其他人。 我已经在 Excel 2010 上测试了这个解决方案。说：“Sheet1”是您的数据所在的工作表的名称，“Sheet2”是您想要重复数据的工作表。 假设您创建了这些工作表，请尝试以下代码。

Sub multiplyRowsByCellValue()
Dim rangeInventory As Range
Dim rangeSingleCell As Range
Dim numberOfRepeats As Integer
Dim n As Integer
Dim lastRow As Long

'Set rangeInventory to all of the Inventory Data
Set rangeInventory = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("D2").End(xlDown))

'Iterate each row of the Inventory Data
For Each rangeSingleCell In rangeInventory.Rows
    'number of times to be repeated copied from Sheet1 column 4 ("C")
    numberOfRepeats = rangeSingleCell.Cells(1, 3).Value

    'check if numberOfRepeats is greater than 0
    If numberOfRepeats > 0 Then
         With Sheets("Sheet2")
            'copy each invetory item in Sheet1 and paste "numberOfRepeat" times in Sheet2

                For n = 1 To numberOfRepeats 
                lastRow = Sheets("Sheet1").Range("A1048576").End(xlUp).Row
                r.Copy
                Sheets("Sheet1").Range("A" & lastRow + 1).PasteSpecial xlPasteValues
            Next
        End With
    End If
Next

End Sub

此解决方案是 David Zemens 解决方案的略微修改版本。

Answer 4

在这里恢复一个旧线程 - 但我在“For Each rngSinglecell In rngQuantityCells”行上收到“运行时错误'424'：需要对象”

Sub DupRowssTEST()
Dim CurrentWB As Workbook 
Dim rngSinglecell As Range
Dim rngQuantityCells As Range
Dim intCount As Integer

Set CurrentWB = ActiveWorkbook

Set rngQuantityCellls = Range("B2", Range("B2").End(xlDown))

For Each rngSinglecell In rngQuantityCells
    If IsNumeric(rngSinglecell.Value) Then
        If rngSinglecell.Value > 0 Then
            For intCount = 1 To rngSinglecell.Value
                Range(rngSinglecell.Address).EntireRow.SpecialCells(xlCellTypeVisible).Copy
                    With CurrentWB.Sheets(1).Range("N" & Rows.Count).End(xlUp).Offset(1)
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                    End With
            Next
        End If
    End If
Next rngSinglecell

End Sub

似乎可能是因为我没有进一步设置'rngSinglecell'，但我认为因为它被调暗为一个范围，所以它会被假定？

对此的任何想法将不胜感激！