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

在工作簿中创建一个代码模块，默认为“Module1”。将以下3个项目粘贴到该模块中，最顶层的Enum声明。您可以更改枚举，例如NumItem = 3会使列中的项目名称为“C”，NumQty会自动为4（“D”），因为它会在下一行中跟随。现在列是A，B和C.

如若私人KNUM

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

私有函数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