vba - 识别列、添加数量、删除重复项

Question

我正在为电气设备编译 BOM。我总共有 18 个 BOMS，每个 BOMS 大约有 160 个项目。我正在寻找一种代码，它可以扫描所有数据并识别重复项，获取它们的值，将它们相加，然后删除重复项。我已经识别并删除了此代码，但我无法将其加起来...

    Sub RemoveDuplicates()

    Dim lastrow As Long

    lastrow = Cells(Rows.Count, "B").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 1

如果您可以输入两个帮助列或将数据复制到其他工作表并这样做，如下图所示，您可能不需要VBA。

只需输入公式，将其复制下来，粘贴值，然后过滤 c 列并删除超过 1 个计数的行。

Answer 2

您可以使用Dictionary 对象：

Option Explicit

Sub RemoveDuplicates()
    Dim lastRow As Long, x As Long, strval As String, storedRow As Long
    Dim toDel As Range  ' collects rows to delete
    Dim dict As Object  ' Dictionary
    Set dict = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Worksheets("Sheet1") ' replace with your own WB and WS
        lastRow = Cells(Rows.Count, "B").End(xlUp).Row
        For x = 1 To lastRow
            strval = .Cells(x, 1).Text & "|" & .Cells(x, 2).Text    ' make a key
            If dict.Exists(strval) Then ' check if this string value has been encountered before
                storedRow = dict(strval)    'retrieve the saved row number
                .Cells(storedRow, 3) = .Cells(storedRow, 3) + .Cells(x, 3)
                If toDel Is Nothing Then
                    Set toDel = .Cells(x, 1)
                Else
                    Set toDel = Union(.Cells(x, 1), toDel)
                End If
            Else
                dict.Add strval, x    'make the new entry in the Dictionary: key = string, value = row number
            End If
        Next x
        If Not toDel Is Nothing Then toDel.EntireRow.Delete
    End With
End Sub

前

后