Excel宏VBA汇总重复值，然后删除重复记录

我试图根据在“A-O”列中发现的重复值来汇总值。我正在使用下面的宏。大约有500k+条记录，下面的宏挂起不好

 Sub Formulae(TargetCol1, TargetCol2, ConcatCol, Col1, Col2, StartRow, EndRow, Sheet)

         Sheets(Sheet).Range(TargetCol1 & CStr(StartRow)).Formula = "=SUMIF($" & ConcatCol & "$" & CStr(StartRow) & ":$" & ConcatCol & "$" & CStr(EndRow) & "," & ConcatCol & CStr(StartRow) & ",$" & Col1 & "$" & CStr(StartRow) & ":$" & Col1 & "$" & CStr(EndRow) & ")"

     Sheets(Sheet).Range(TargetCol1 & CStr(StartRow)).Select
    Selection.Copy
    Sheets(Sheet).Range(TargetCol1 & CStr(EndRow)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Application.CutCopyMode = False
    Selection.FillDown

    Call PasteSpecial(TargetCol1, "T", StartRow, EndRow)

    Sheets(Sheet).Range(TargetCol2 & CStr(StartRow)).Formula = "=SUMIF($" & ConcatCol & "$" & CStr(StartRow) & ":$" & ConcatCol & "$" & CStr(EndRow) & "," & ConcatCol & CStr(StartRow) & ",$" & Col2 & "$" & CStr(StartRow) & ":$" & Col2 & "$" & CStr(EndRow) & ")"

     Sheets(Sheet).Range(TargetCol2 & CStr(StartRow)).Select
    Selection.Copy
    Sheets(Sheet).Range(TargetCol2 & CStr(EndRow)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Application.CutCopyMode = False
    Selection.FillDown

    Call PasteSpecial(TargetCol2, "U", StartRow, EndRow)


 End Sub


Sub PasteSpecial(Col1, Col2, StartRow, EndRow)

    Range(Col1 & CStr(StartRow)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range(Col2 & CStr(StartRow)).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End Sub

让我简单地解释一下宏。我有列“A-O”，我必须对它们进行分组……根据分组，我必须对列“P，Q”求和。我有一个函数，它从16列中生成一个连接字符串，并存储在“AA”列中。基于此列，我使用sumif函数对所有重复值求和

 =SUMIF($AA$2:$AA$500000,$AA2,$P$2:$P$500000)
 =SUMIF($AA$2:$AA$500000,$AA2,$Q$2:$Q$500000)

然后，我将“粘贴特殊值”复制为上述值，以删除2个新列中的公式（上述宏代码中的“粘贴特殊函数”）

最后，我调用remove duplicates来删除重复的值

 =SUMIF($AA$2:$AA$500000,$AA2,$P$2:$P$500000)
 =SUMIF($AA$2:$AA$500000,$AA2,$Q$2:$Q$500000)

我使用了.RemovedUpplicates方法，即使在如此庞大的数据集上，该方法似乎也运行得相当快。excel中是否有预定义的函数，它甚至可以对重复项的值求和，然后删除重复项

 Sub Remove_Duplicates_In_A_Range(StartRow, EndRow, Sheet, StartCol, EndCol, level)



Sheets(Sheet).Range(StartCol & CStr(StartRow) & ":" & EndCol & CStr(EndRow)).RemoveDuplicates Columns:=20, Header:=xlNo

End Sub

上面的逻辑挂起，占用所有CPU资源并严重崩溃

有人请优化上述宏，使其与500k+记录一起工作。最多1-2分钟的性能是可以接受的

请帮忙

编辑：按500k+记录，我的意思是A1:O500000。我应该以这种方式检查A1、B1、C1、D1、E1、F1、G1、H1、I1、J1、K1、L1、M1、N1、O1与A2、B2、C2、D2、E2、F2、G2、H2、I2、J2、K2、L2、M2、N2、O2和A3、B3、C3、D3、E3、G3、H3、I3、J3、K3、L3、M3、N3、O3等的组合是否存在重复项……直到A500000、B500000等

简言之，我应该检查整个A1-O1组与整个A2-O2或A3-O3或。。。。。A500k-O500k等

对于整个A-O记录集之间的每个匹配，我需要对它们各自的p、Q列求和。例如，A1-O1组与A2-O2组匹配，然后添加P1、Q1和P2、Q2，并存储在P1、Q1或其他位置

在任何一种情况下，我都需要保留每个原始记录集，比如A1-O1，以及它的重复项和它自己在P1，Q1中的值的总和

我想我们现在不能在这里附上excel表的演示，可以吗(

EDIT2:

用于跨所有单元格复制sumif公式的函数

 Sub PreNettingBenefits(StartRow1, EndRow1, StartRow2, EndRow2, Col_Asset, Col_Liab, Src_Col_Asset, Src_Col_Liab, ConcatCol, Src_ConcatCol, level, Sheet2, Sheet1)

'=SUMIF(Sheet1!$AA$2:$AA$81336,Sheet2!AA2,Sheet1!$P$2:$P$81336)
Application.Calculation = xlCalculationAutomatic
Sheets(Sheet2).Range(Col_Asset & CStr(StartRow2)).Formula = "=SUMIF(" & Sheet1 & "!$" & Src_ConcatCol & "$" & CStr(StartRow1) & ":$" & Src_ConcatCol & "$" & CStr(EndRow1) & "," & Sheet2 & "!" & ConcatCol & CStr(StartRow2) & "," & Sheet1 & "!$" & Src_Col_Asset & "$" & CStr(StartRow1) & ":$" & Src_Col_Asset & "$" & CStr(EndRow1) & ")"
Sheets(Sheet2).Range(Col_Asset & CStr(StartRow2)).Select
Selection.Copy
MsgBox Sheets(Sheet2).Range(Col_Asset & CStr(EndRow2)).Address
Sheets(Sheet2).Range(Col_Asset & CStr(EndRow2)).Select
Range(Col_Asset & CStr(StartRow2) & ":" & Col_Asset & CStr(EndRow2)).Select
Application.CutCopyMode = False
Selection.FillDown




Sheets(Sheet2).Range(Col_Liab & CStr(StartRow2)).Formula = "=SUMIF(" & Sheet1 & "!$" & Src_ConcatCol & "$" & CStr(StartRow1) & ":$" & Src_ConcatCol & "$" & CStr(EndRow1) & "," & Sheet2 & "!" & ConcatCol & CStr(StartRow2) & "," & Sheet1 & "!$" & Src_Col_Liab & "$" & CStr(StartRow1) & ":$" & Src_Col_Liab & "$" & CStr(EndRow1) & ")"
Sheets(Sheet2).Range(Col_Liab & CStr(StartRow2)).Select
Selection.Copy
MsgBox Sheets(Sheet2).Range(Col_Liab & CStr(EndRow2)).Address
Sheets(Sheet2).Range(Col_Liab & CStr(EndRow2)).Select
Range(Col_Liab & CStr(StartRow2) & ":" & Col_Liab & CStr(EndRow2)).Select
Application.CutCopyMode = False
Selection.FillDown


Application.Calculation = xlCalculationManual


End Sub

---

它挂起得很糟糕。在30k-40k行中复制公式有什么问题。有人能优化代码吗？

执行代码时，您不应该选择每个单元格

顺便说一句，如果你看一下你的代码，有些语句是无用的：

Sheets(Sheet).Range(TargetCol1 & CStr(StartRow)).Select
Selection.Copy

它从不粘贴

---

有关性能问题，请参阅此线程中的一些提示：

在执行代码时，您不应该选择每个单元格

顺便说一句，如果你看一下你的代码，有些语句是无用的：

Sheets(Sheet).Range(TargetCol1 & CStr(StartRow)).Select
Selection.Copy

它从不粘贴

---

关于性能问题，请参阅此线程中的一些提示：

据我所知，问题的实质是找到重复项并将其相加，然后删除它们。您还提到了对它们进行分组，但不清楚如何进行分组。在任何情况下，我都会放弃宏。对单个行的操作在该数据集上不起作用

以下是我将采取的一些步骤。请修改它们以满足您的需要：

使用concatenate函数在数据集右侧创建一个新列

=concatenate(a2,b2,c2,d2,e2)

创建一个名为Dups的列，并使用以下命令填充该列：

=if(countif(dataSetNamedRange,aa2)>1,1,0)

---

在上面的代码中，aa2引用了该行的连接列。上面的结果是，您现在标记了所有DUP。现在使用“数据”菜单中的筛选工具创建一个排序或筛选，以满足您的分组需要。要添加值，请使用DSum。要删除DUP，请使用高级筛选。祝您好运。

q的本质根据我的理解，问题是找到重复项并将其相加，然后删除它们。您还提到了对它们进行分组，但不清楚如何进行分组。无论如何，我会放弃宏。对单个行的操作在该数据集上不起作用

以下是我将采取的一些步骤。请修改它们以满足您的需要：

使用concatenate函数在数据集右侧创建一个新列

=concatenate(a2,b2,c2,d2,e2)

创建一个名为Dups的列，并使用以下命令填充该列：

=if(countif(dataSetNamedRange,aa2)>1,1,0)

---

在上面的代码中，aa2引用了该行的连接列。上面的结果是，您现在标记了所有DUP。现在，使用“数据”菜单中的“筛选”工具创建一个排序或筛选，以满足您的分组需要。要添加值，请使用DSum。要删除DUP，请使用高级筛选。祝您好运。

您添加重复项的方式有误。由于您对正在处理的数据的详细信息知之甚少，我不知道这是否相同，但我使用1到10000之间的随机数填充了A1:O33334（超过500k个单元格）

使用dictionary对象（我以热爱和过度使用它而闻名），我检查了所有这些对象，只对重复的值求和，然后将唯一的元素列表添加到sheet2的a列中

使用词典的原因：

• 你可以剔除重复的
• 您可以检查字典中是否存在值
• 您可以轻松地将唯一列表转换到Excel

重复检查和添加以及复制唯一单元格只需2秒钟。以下代码供您参考

Sub test()

Application.ScreenUpdating = False
Dim vArray As Variant
Dim result As Long
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")

vArray = Range("A1:O33334").Value

On Error Resume Next
For i = 1 To UBound(vArray, 1)
    For j = 1 To UBound(vArray, 2)
        If dict.exists(vArray(i, j)) = False Then
            dict.Add vArray(i, j), 1
        Else
            result = result + vArray(i, j)
        End If
    Next
Next

Sheet2.Range("a1").Resize(dict.Count).Value = _
Application.Transpose(dict.keys)

Application.ScreenUpdating = True
MsgBox "Total for duplicate cells: " & result & vbLf & _
    "Unique cells copied: " & dict.Count

End Sub

---

您添加重复项的方式一定出了很大的问题。由于您对正在处理的数据的详细信息知之甚少，我不知道这是否相同，但我使用1到10000之间的随机数填充了A1:O33334（超过500k个单元格）

使用dictionary对象（我以热爱和过度使用它而闻名），我检查了所有这些对象，只对重复的值求和，然后将唯一的元素列表添加到sheet2的a列中

使用词典的原因：

• 您可以删除重复项