如何在不同情况下删除excel中的重复项（VBA）？

Question

我需要将相应的值汇总到正确的列中，但还要删除重复项。 这是交易：

例如，如果我有从 A 到 F 的列。如果列 A 到 E 与另一行相同，则宏会删除该行并保存较旧的行。 如果 A 到 C 列与另一现有行相同，则宏删除另一行并将 D 和 E 列中的相应值添加到剩余行。 这是一个例子：

cell1 cell2 cell3 cell4 cell5 cell6
1      1     1     1     1     1
2      2     2     2     2     2
2      2     2     2     2     2
1      1     1     2     2     1
3      3     3     3     3     3

After macro:

cell1  cell2 cell3 cell4 cell5 cell6
1      1     1      3     3     1 
2      2     2      2     2     2
3      3     3      3     3     3 

所以现在，宏已经删除了第 4 行（因为它在 A 列到 C 与第 1 行具有相同的值）并将 D 和 E 列的相应值添加到第 1 行。此外，第 2 行和第 3 行是从 A 列到 E 列的重复项，所以宏删除第 3 行。

这是我尝试过的一个例子（我之前得到了 sum-problem 的帮助（来自@JvdV）并将相应的值添加到正确的值中，但我不知道如何正确删除重复项..）

Class 模块：

Public Col1 As Variant
Public Col2 As Variant
Public Col3 As Variant
Public Col4 As Variant
Public Col5 As Variant
Public Col6 As Variant

模块：

Dim x As Long, arr As Variant, lst As Class1
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

With Sheet1
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A1:F" & x).Value
End With

.Range("A1:F" & x).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes

For x = LBound(arr) To UBound(arr)
    If Not dict.Exists(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)) Then
        Set lst = New Class1
        lst.Col1 = arr(x, 1)
        lst.Col2 = arr(x, 2)
        lst.Col3 = arr(x, 3)
        lst.Col4 = arr(x, 4)
        lst.Col5 = arr(x, 5)
        lst.Col6 = arr(x, 6)
        dict.Add arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3), lst
    Else
        dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col4 = dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col4 + arr(x, 4)
        dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col5 = dict(arr(x, 1) & "|" & arr(x, 2) & "|" & arr(x, 3)).Col5 + arr(x, 5)
    End If
Next x

With Sheet1
    x = 1
    For Each Key In dict.Keys
        .Cells(x, 1).Value = dict(Key).Col1
        .Cells(x, 2).Value = dict(Key).Col2
        .Cells(x, 3).Value = dict(Key).Col3
        .Cells(x, 4).Value = dict(Key).Col4
        .Cells(x, 5).Value = dict(Key).Col5
        .Cells(x, 6).Value = dict(Key).Col6
        x = x + 1
    Next Key
End With

End Sub

Answer 1

代码中的一些错误，包括在删除第一个重复项之前填充数组以及将RemoveDuplicates放在With语句之外并包括 F 列。为了使您的代码正常工作，您可以尝试以下操作：

_前

Sub Test()

Dim x As Long, arr As Variant, lst As Class1
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

With Sheet1

    'Step one: Delete duplicates over columns A-E
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1:F" & x).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes

    'Step two: Populate your array
    x = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A2:F" & x).Value

    'Step three: Clear range
    .Range("A2:F" & x).ClearContents

    'Step Four: Go through your array and populate a dictionary
    For x = LBound(arr) To UBound(arr)
        Set lst = New Class1
        lst.Col1 = arr(x, 1)
        lst.Col2 = arr(x, 2)
        lst.Col3 = arr(x, 3)
        lst.Col4 = arr(x, 4)
        lst.Col5 = arr(x, 5)
        lst.Col6 = arr(x, 6)
        KeyX = Join(Array(arr(x, 1), arr(x, 2), arr(x, 3)), "|")
        If dict.Exists(KeyX) = False Then
            dict.Add KeyX, lst
        Else
            dict(KeyX).Col4 = dict(KeyX).Col4 + arr(x, 4)
            dict(KeyX).Col5 = dict(KeyX).Col5 + arr(x, 5)
        End If
    Next x

    'Step five: Go through your dictionary and write to sheet
    x = 2
    For Each key In dict.Keys
        .Range(.Cells(x, 1), .Cells(x, 6)).Value = Array(dict(key).Col1, dict(key).Col2, dict(key).Col3, dict(key).Col4, dict(key).Col5, dict(key).Col6)
        x = x + 1
    Next key

End With

End Sub

_后

让我知道进展如何 =)