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

Question

我想总结基于“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周新的cols（在上面的宏代码PasteSpecial的功能） 。

最后我所说的删除重复删除

我已经使用了.removeduplicates方法，这似乎相当快，即使在这样一个庞大的数据集的工作重复值。在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，F3，G3，H3，I3，J3，K3，L3，M3，N3， O3等....直到A500000，B500000等...。

总之我应该检查整个A1-O1集与整个A2-O2或A3-O3或..... A500k-O500k等

对于整个AO之间的每场比赛都匹配记录集我需要总结他们各自的P，Q列。比如说A1-O1设置与A2-O2设置匹配，然后加P1，Q1和P2，Q2并存储到P1，Q1或者其他东西中。

无论哪种情况，我需要保留每个原始记录集say，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 

它挂很糟糕Whts问题在复制跨30K-40K行的公式可能有人请优化代码？

Answer 1

在添加重复项的过程中，一定会出现严重错误。由于您对所使用的数据的细节不甚了解，因此我不知道这是否相同，但我使用1到10,000之间的随机数填充了A1：O33334（超过500k个单元格）。

使用字典对象（我为我的爱和过度使用而闻名），我浏览了所有这些对象并仅汇总了重复值，然后将单独的元素列表放入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 

Answer 2

执行代码时，您不应该在每个单元中使用select。

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

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

是从来没有粘贴

出于性能方面的问题，请参阅该主题中的一些技巧：Benchmarking VBA Code

Answer 3

据我了解，这个问题的实质是找到重复并添加它们，然后删除它们。你还提到将它们分组，但不清楚如何。无论如何，我会抛弃宏。单个行上的操作不适用于该数据集。

以下是我将采取的一些步骤。修改它们以适合您的需求：

使用连接函数在数据集右侧创建一个新列。例如

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

创建称为DUP的柱，并使用以下来填充它：

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

在上面的代码，AA2是指该行的级联列。上面的结果是，你现在已经标记了所有的下注。现在使用“数据”菜单中的过滤器工具创建一个排序或过滤器以适应您的分组需求。要合计这些值，请使用DSum。要删除dups，请使用高级过滤器。祝你好运。

Answer 4

，因为它会得到长期我加入这个作为第二个答案...

监守我是一个顽固的骡子，我尝试了很多不同的东西，我觉得你已经达到极限Excel可以做什么。我能想出是最好的功能是这样的，并注意我使用50,000行，而不是你：500,000

• 50,000行与100行唯一的，随机分布：1M：47S
• 50,000行50唯一的行，随机分布：57S
• 50,000行与25点独特的行，随机分布：28S
• 50,000行与10点独特的行，随机分布：12S
• 50,000行与5个独特的行，随机分布：6S

正如您所看到的，随着唯一行数的增加，函数将会恶化。我有很多在这里古怪的想法，所以我想我会分享我的代码进行研究的缘故：

• 我拿750K细胞的整个范围，并将其转储到一个变量数组（0.2秒）
• 我倾倒在P & q行成一个类似的变量数组以备后用
• 我做从变量数组50000串（行）的阵列（只有1秒左右！）
• 我说再见大量的变体阵列来清理内存
• 我开始我的循环遍历每一行，比较所有50,000列...
• 如果发现重复数据删除的行，它添加到字典中重复数据删除，所以我们没有做该行同样的过程后
• 当傻瓜被发现，它的增值P，& Q总计在问题
• 行中的P & Q检查所有50K行后，我们总拍入行R列和如果该行已经注意到作为dupedict愚弄的人在
• 移动，我们跳过它（邪恶的要当心！）

Sub test() 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Dim rowArray As Variant 
Dim totalArray As Variant 
Dim i As Long, j As Long 
Dim dupeDict As Object 
Set dupeDict = CreateObject("scripting.dictionary") 
Dim count As Long 
Dim rowData() As String 

'dump the cells into an single array 
rowArray = Range("A1:O50000").Value 

'grab totals from P and Q to keep them seperate 
totalArray = Range("P1:Q50000").Value 

'create strings for each row 
ReDim rowData(1 To 50000) 

'create a string for each row 
For i = 1 To 50000 
    For j = 1 To 15 
     rowData(i) = rowData(i) & rowArray(i, j) 
    Next 
Next 

'free up that memory 
Set rowArray = Nothing 

'check all rows, total P & Q if match 
On Error Resume Next 
For i = 1 To 50000 
    'skip row and move to next if we've seen it 
    If dupeDict.exists(i) = True Then 
     GoTo Dupe 
    End If 
    count = 0 
    For j = 1 To 50000 
     If rowData(i) = rowData(j) Then 
      dupeDict.Add j, 1 'add that sucker to the dupe dict 
      count = count + totalArray(j, 1) + totalArray(j, 2) 
     End If 
     'enter final total in column R 
     Cells(i, 18).Value = count 
    Next 
Dupe: 
Next 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

End Sub