Excel VBA组合重复的行并添加数量

我有这样的数据：

Col A | Col B | Col C name 1| Item 1| 3 name 2| Item 3| 1 name 3| Item 2| 2 name 2| Item 3| 6 name 3| Item 2| 4 name 2| Item 3| 3 

我需要一行代码来添加重复行的最后一列数量，然后删除重复的行。 所以上表应该是这样的：

 Col A | Col B | Col C name 1| Item 1| 3 name 2| Item 3| 10 name 3| Item 2| 6 

我已经尝试了多种方式从其他人的问题，但我不断收到“错误：400”。

这里有两个例子：

  For Each a In tm.Range("B2", Cells(Rows.Count, "B").End(xlUp)) For r = 1 To Cells(Rows.Count, "B").End(xlUp).Row - a.Row If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4) a.Offset(r, 0).EntireRow.Delete r = r - 1 End If Next r Next a With Worksheets("Card Test") With .Range("b2:e2").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row) .Copy With .Offset(, .Columns.Count + 1) .PasteSpecial xlPasteAll ' copy value and formats .Columns(2).Offset(1).Resize(.Rows.Count - 1, 2).FormulaR1C1 = "=SUMIF(C1,RC1,C[-" & .Columns.Count + 1 & "])" .Value = .Value .RemoveDuplicates 1, xlYes End With End With End With 

另外我应该提到，我有两个工作表，使用macros的button将在不同的数据表上。 这似乎也造成了问题。

Answer 1

你可以使用FOR循环来解决你的问题：

 Sub RemoveDuplicates() Dim lastrow As Long lastrow = Cells(Rows.Count, "A").End(xlUp).Row For x = lastrow To 1 Step -1 For y = 1 To lastrow If Cells(x, 1).Value = Cells(y, 1).Value And Cells(x, 2).Value = Cells(y, 2).Value And x > y Then Cells(y, 3).Value = Cells(x, 3).Value + Cells(y, 3).Value Rows(x).EntireRow.Delete Exit For End If Next y Next x End Sub 

Answer 2

在工作簿中创build一个代码模块，默认为“Module1”。 将以下3个项目粘贴到该模块中，Enum声明位于最上面。 你可以改变枚举types，比如NumItem = 3会让你的项目名称为“C”，NumQty自动为4（“D”），因为它跟在下一行。 现在列是A，B和C.

私人使用数量

 NumName = 1 ' Column Names NumItem NumQty NumFirstRow = 2 ' First data row 

End Enum

Sub CreateMergedList（）

 Dim Ws As Worksheet Dim Comp As String, Comp1 As String Dim R As Long, Rend As Long, Rsum As Long Dim Qty As Single Set Ws = Worksheets("Source") Ws.Copy Before:=Sheets(1) With Ws ' There is one caption row which is excluded from sorting With .UsedRange .Sort .Columns(NumName), Key2:=.Columns(NumItem), Header:=xlYes Rend = .Rows.Count End With For R = NumFirstRow To Rend - 1 If Comp = vbNullString Then Comp = CompareString(Ws, R) Comp1 = CompareString(Ws, R + 1) If StrComp(Comp, Comp1) Then Comp = vbNullString Rsum = R + 1 Else If Rsum = 0 Then Rsum = NumFirstRow Qty = .Cells(Rsum, NumQty).Value .Cells(Rsum, NumQty).Value = Qty + .Cells(R + 1, NumQty).Value .Cells(R + 1, NumName).Value = "" End If Next R For R = Rend To (NumFirstRow - 1) Step -1 If .Cells(R, NumName).Value = "" Then .Rows(R).Delete Next R End With Application.DisplayAlerts = False Worksheets(1).Delete Application.DisplayAlerts = True End Sub 

Private Function CompareString（Ws As Worksheet，R As Long）As String

 With Ws.Rows(R) CompareString = .Cells(NumName).Value & "|" & .Cells(NumItem).Value End With End Function 

在主过程的顶部，将工作表“源”的名称更改为您自己的名称，项目和数量工作表的名称。

代码将首先制作工作表的副本。 然后它会按名称和项目sorting。 之后，它将结合数量，最后删除多余的行。

在代码结束时，副本被删除。 如果要提示您允许删除，请在“Application.DisplayAlerts = False”行的开头添加一个撇号，以使该命令无效。

从任何button的Click事件调用过程“CreateMergedList”为此目的。 玩的开心！

Answer 3

你可以使用Dictionary对象

 Option Explicit Sub main() Dim cell As Range, dataRng As Range Dim key As Variant With Worksheets("Card Test") Set dataRng = .Range("A1", .Cells(.Rows.count, "A").End(xlUp)) End With With CreateObject("Scripting.Dictionary") For Each cell In dataRng key = cell.Value & "|" & cell.Offset(, 1).Value .item(key) = .item(key) + cell.Offset(, 2).Value Next dataRng.Resize(, 3).ClearContents dataRng.Resize(.count) = Application.Transpose(.Keys) dataRng.Resize(.count).Offset(, 2) = Application.Transpose(.Items) dataRng.Resize(.count).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|" End With End Sub