Excel的VBA合併重複的行，並添加量

Question

我有一個看起來像這樣的數據：

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 

另外我應該指出，我有兩個工作表和使用宏將是在一個不同的片材比數據的按鈕。這似乎也造成了問題。

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

工作簿創建代碼模塊，默認情況下「模塊1」。將以下3個項目粘貼到該模塊中，Enum聲明位於最上方。你可以改變枚舉類型，就像NumItem = 3一樣，會讓你的項目名稱爲「C」，NumQty自動爲4（「D」），因爲它在下一行中。眼下列A，B和C.

私人枚舉民

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

末枚舉

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 

在主程序的頂部，改變工作表「的名字來源「，無論您的姓名，項目和數量都是您自己的工作表的名稱。

該代碼將首先製作工作表的副本。然後它會按名稱和項目排序。之後，它將結合數量，最後刪除多餘的行。

在代碼結束時，副本被刪除。如果您想要提示允許刪除，請在「Application.DisplayAlerts = False」行的開頭添加一個撇號，以使該命令無效。

從您爲此目的的任何按鈕的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