在Excel中为每个订单项创build唯一的条目
我需要在Excel中创build一个macros的帮助，其中它抓取某个单元格，并根据单元格的内容复制整个行x次。
为了说清楚，假设我有两行：
| Order # | Item | Qty | | 30001 | bag | 3 | | 30002 | pen | 1 |
我想让macros执行的是在Qty列下面的数字，并复制整行，并插入一个新的行，下面有完全相同的内容。 它的次数取决于Qty单元中的数字。 此外，它还在Order #单元格中附加了一个三位数字，使其成为唯一的参考点。 最终的结果是什么？
| Order # | Item | Qty | | 30001-001 | bag | 1 | | 30001-002 | bag | 1 | | 30001-003 | bag | 1 | | 30002-001 | pen | 1 |
这里很难解释，但我希望你明白这一点。 在此先感谢，大师！
以下代码支持数据中间的空白行。
如果Qty = 0 ，则不会在输出表中写入Item 。
请插入至less1行数据，因为如果没有数据，它将不起作用:)
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
我希望它可以帮助你。 我玩得很开心！
一种方法：按需插入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