在 Excel 中为每个行项目创建一个唯一条目

Posted 2023-02-19

【中文标题】在 Excel 中为每个行项目创建一个唯一条目

【英文标题】：Creating a unique entry for each line item in Excel

【发布时间】：2014-09-30 03:39:51

【问题描述】：

我需要帮助在 Excel 中创建一个宏，其中它抓取某个单元格并根据单元格的内容复制整行 x 次数。

为了清楚起见，假设我有 2 行：

|  Order #  |  Item  |  Qty  |
|   30001   |   bag  |   3   |
|   30002   |   pen  |   1   |

我想要宏做的是抓取Qty 列下的数字并复制整行并在其下插入具有完全相同内容的新行。它执行此操作的次数取决于Qty 单元格中的数字。此外，它还在Order # 单元格中附加了一个三位数字，使其成为唯一的参考点。最终结果应该是什么：

|  Order #  |  Item  |  Qty  |
| 30001-001 |   bag  |   1   |
| 30001-002 |   bag  |   1   |
| 30001-003 |   bag  |   1   |
| 30002-001 |   pen  |   1   |

这里很难解释，但我希望你明白这一点。在此先感谢各位大师！

【参考方案1】：

以下代码支持数据中间有空行。

如果Qty = 0，则不会在输出表中写入Item。

请至少插入1行数据，没有数据就不行:)

Option Explicit

Sub caller()
    ' Header at Row 1:
    '   "A1" = Order
    '   "B1" = Item
    '   "C1" = Qty
    '
    ' Input Data starts at Row 2, in "Sheet1"
    '
    ' Output Data starts at Row 2, in "Sheet2"
    '
    ' Sheets must be manually created prior to running this program
    Call makeTheThing(2, "Sheet1", "Sheet2")
End Sub


Sub makeTheThing(lStartRow As Long, sSheetSource As String, sSheetDestination As String)

    Dim c               As Range
    Dim rOrder          As Range
    Dim sOrder()        As String
    Dim sItem()         As String
    Dim vQty            As Variant
    Dim sResult()       As String
    Dim i               As Long

    ' Reads
    With ThisWorkbook.Sheets(sSheetSource)

        Set rOrder = .Range(.Cells(lStartRow, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) ' It will work if there are blank lines in the middle!
        i = rOrder.Rows.Count
        ReDim sOrder(1 To i)
        ReDim sItem(1 To i)
        ReDim vQty(1 To i)

        i = 1
        For Each c In rOrder
            sOrder(i) = Trim(c.Text)
            sItem(i) = Trim(c.Offset(0, 1).Text)
            vQty(i) = c.Offset(0, 2).Value
            i = i + 1
        Next c

    End With

    ' Processes
    sResult = processData(sOrder, sItem, vQty)

    ' Writes
    ThisWorkbook.Sheets(sSheetDestination).Range("A" & lStartRow).Resize(UBound(sResult, 1), UBound(sResult, 2)).Value = sResult

End Sub


Function processData(sOrder() As String, sItem() As String, vQty As Variant) As String()

    Dim i               As Long
    Dim j               As Long
    Dim k               As Long
    Dim sResult()       As String

    j = WorksheetFunction.Sum(vQty) ' That's why vQty had to be Variant!
    ReDim sResult(0 To j, 1 To 3)
    k = 0

    For i = 1 To UBound(sOrder)
        For j = 1 To vQty(i)
            sResult(k, 1) = sOrder(i) & "-" & Format(j, "000")
            sResult(k, 2) = sItem(i)
            sResult(k, 3) = "1"
            k = k + 1
        Next j
    Next i

    processData = sResult

End Function

希望对你有帮助。我玩得很开心！

【参考方案2】：

一种方式：向下走qty列，根据需要插入，然后跳转到下一个原始行；

Sub unwind()
    Dim rowCount As Long, cell As Range, order As String, i As Long, r As Long

    Set cell = Range("C1")
    rowCount = Range("C" & rows.Count).End(xlUp).Row

    For i = 1 To rowCount
        order = cell.Offset(0, -2).Value

        For r = 0 To cell.Value - 1
            If (r > 0) Then cell.Offset(r).EntireRow.Insert
            cell.Offset(r, 0).Value = 1
            cell.Offset(r, -1).Value = cell.Offset(0, -1).Value
            cell.Offset(r, -2).Value = order & "-" & Format$(r + 1, "000")
        Next

        Set cell = cell.Offset(r, 0)
    Next
End Sub