Vba 复制相似值的数据

我有一个电子表格，其中包含发票编号和详细编号。明细编号指向发票上信息所在的行。一个电子表格上可以有多个发票，但不幸的是，只有一个发票和明细组合在一行上。因此，电子表格上的第1行将在a列中包含一张发票，在B列中包含一张详细信息，然后下一张发票从第2行开始。我的问题是，我想创建一个程序，该程序将查找任何重复的发票，并将相关的详细信息编号复制粘贴到一行，以便最终得到：

InvoiceA. Detail1. Detail2. Detail3. Etc
InvoiceB. Detail1. Detail2. Etc

与之相反：

InvoiceA. Detail
InvoiceA. Detail
InvoiceB. Detail
InvoiceB. Detail

我曾考虑过使用一个宏（带有发票高级过滤器）遍历每个单元格-计算可见行数并将详细信息复制到电子表格上的指定位置，然后删除只有一个详细信息编号的额外发票编号。然而，这似乎效率低下

这是我到目前为止所做的

Sub detail()
   Dim wb As Workbook, ws As Worksheet
   Dim dtl1 As Range, dtl2 As Range, dtl3 As Range, dtl4 As Range, dtl5 As Range, dtl6 As Range

   Set wb = ThisWorkbook
   Set ws = wb.Sheets("Sheet1")
   lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
   Set inv = ws.Range("D2:D" & lastRow)
   Set dtl1 = ws.Range("E2:E" & lastRow)
  '
  'ws.Range("E:I").EntireColumn.Insert
  'With ws
     '.Range("E1").Value = "Detail 2"
     '.Range("F1").Value = "Detail 3"
     '.Range("G1").Value = "Detail 4"
     '.Range("H1").Value = "Detail 5"
     '.Range("I1").Value = "Detail 6"
  'End With

   For i = 1 To ws.Rows.Count
      If inv.Cells(i, 1).Value = "" Then
         Exit Sub
      End If
      If inv.Cells(i, 1) = inv.Cells(i, 1).Offset(-1, 0) And dtl1.Cells(i, 1).Offset(-1, 1) = "" Then
         dtl1.Cells(i, 1).Copy
         dtl1.Cells(i, 1).Offset(-1, 1).PasteSpecial
         If inv.Cells(i, 1) = inv.Cells(i, 1).Offset(-2, 0) And dtl1.Cells(i, 1).Offset(-2, 2) = "" Then
           dtl1.Cells(i, 1).Copy
           dtl1.Cells(i, 1).Offset(-2, 2).PasteSpecial
           If inv.Cells(i, 1) = inv.Cells(i, 1).Offset(-3, 0) And dtl1.Cells(i, 1).Offset(-3, 3) = "" Then
              dtl1.Cells(i, 1).Copy
              dtl1.Cells(i, 1).Offset(-3, 3).PasteSpecial
              If inv.Cells(i, 1) = inv.Cells(i, 1).Offset(-4, 0) And dtl1.Cells(i, 1).Offset(-4, 4) = "" Then
                 dtl1.Cells(i, 1).Copy
                 dtl1.Cells(i, 1).Offset(-4, 4).PasteSpecial
                 If inv.Cells(i, 1) = inv.Cells(i, 1).Offset(-5, 0) And dtl1.Cells(i, 1).Offset(-5, 5) = "" Then
                    dtl1.Cells(i, 1).Copy
                    dtl1.Cells(i, 1).Offset(-5, 5).PasteSpecial
                    If inv.Cells(i, 1) = inv.Cells(i, 1).Offset(-6, 0) And dtl1.Cells(i, 1).Offset(-6, 6) = "" Then
                       dtl1.Cells(i, 1).Copy
                       dtl1.Cells(i, 1).Offset(-6, 6).PasteSpecial
                    End If
                 End If
              End If
           End If
        End If
     End If
  Next i
End Sub

---

试试这个宏。它将创建一个新的工作表，按行对发票进行分组。 它假设数据在表格（“发票”）列A和B中，从第二行开始。请根据您的案例调整这些参数

Sub CreateGroupedInvoiceSheet()
    Application.screenUpdating = False
    Dim src As Range: Set src = Sheets("Invoice").Range("A2")
    Dim dest As Range: Set dest = Sheets.Add.Range("A2")
    Dim lastR As Long: lastR = Sheets("Invoice").Range("A" & Rows.count).End(xlUp).Row
    Dim curInvoice As Variant

    Do Until src.Row > lastR
        curInvoice = src.Value
        src.Resize(1, 2).Copy dest
        Set dest = dest.Offset(0, 2)
        Set src = src.Offset(1, 0)
        Do While src.Value = curInvoice
            dest.Value = src.Offset(0, 1).Value
            Set dest = dest.Offset(0, 1)
            Set src = src.Offset(1, 0)
         Loop
         Set dest = dest.Offset(1, 0).End(xlToLeft)
    Loop
    Application.screenUpdating = True
End Sub

---

您的数据是否已按发票编号排序？是的，对应的发票都在一行中。在更改发票编号之前始终有一个空行，如图所示，对吗？不，没有空行，正下方的每一行都是发票和明细的组合。我将在上面发布我的想法。我不知道如何通过Jpeg上传我的excel。上传的图像效果不好。看起来效果不错！非常感谢你。我对VBA不是很精通，你能解释一下你的代码中你一直在做什么吗？所以将来我可能会为自己写这样的东西。@MCJNY1992很高兴它有帮助。简而言之，

Do-Until

循环（相当于

Do-While-Not

）将跨越范围直到最后一行。内部循环将跨越属于同一发票的子范围，只要发票标识符相同，就将明细移动到同一行。直到找到新的发票标识符为止。