ExcelmacrosVBA来总结重复的值，然后删除重复的logging

我正在尝试总结基于“AO”列中find的重复的值。 我正在使用下面的macros。 有大约500k +logging，下面的macros挂不好。 

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

让我简单地解释这个macros。 我有列“AO”，我必须把他们分组…我基于分组，我必须总结列“P，Q”。 我有一个函数，使16个列中的连接string，并存储在“AA”列。 基于这一列，我使用sumif函数对所有重复值进行求和 

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

然后，我复制粘贴特殊为'价值'上面的值删除公式，在2新的列（pasteSpecial函数在上面的macros代码）。

最后我调用删除重复删除重复的值

我已经使用了.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资源和崩溃坏…

有人请优化以上的macros，使其与500K +logging工作。 最多1-2分钟的performance是可以接受的。

请帮忙！！！

编辑：由500k +logging我的意思是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等…。

总之，我应该检查整个A2-O2或A3-O3或… A500k-O500k等整个A1-O1套赛

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

在任何一种情况下，我都需要保留每个原始logging集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的行上复制公式的问题。 有人可以请优化代码？

一些东西一定是非常错误的，你如何做添加的重复。 由于您对所使用的数据的详细信息不甚了解，因此我不知道这是否相同，但我使用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

执行代码时不应select每个单元格。

顺便说一句，如果你看看你的代码，一些陈述是无用的： 

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

永远不会被粘贴

对于性能问题，请参阅此主题中的一些技巧： 基准VBA代码

根据我的理解，问题的实质是find重复项并将其添加，然后删除它们。 你也提到了分组，但是目前还不清楚。 无论如何，我会抛弃macros。 单个行上的操作不会在该数据集上工作。

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

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

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

创build一个名为Dups的列，并使用以下内容填充它： 

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

在上面的代码中，aa2指向该行的连接列。 以上的结果是，你现在已经把所有的下注都标记了。 现在使用“数据”菜单中的filter工具创build一个sorting或filter，以适应您的分组需求。 要合计值，使用DSum。 要删除dups，请使用高级filter。 祝你好运。

我将这个作为第二个答案，因为它会变长…

因为我是一个顽固的mule子，我尝试了很多不同的东西，我想你已经达到了Excel能做的极限。 我能想到的最好的function就是这个，注意我使用的是50000行，而不是500000。

  • 50,000行，100行，随机分布：1m：47s
  • 50,000行，50行，随机传播：57s
  • 50,000行，25行，随机播放：28s
  • 5万行，10行，随机播放：12s
  • 5万行，5行，随机分布：6s

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

  • 我把整个750K的单元格转换成一个变体数组（0.2秒）
  • 我将P＆Q行转储到一个类似的变体数组中以备后用
  • 我从variables数组中创build了50000个string（行）的数组（只有1秒左右！）
  • 我告别了大规模的变种arrays来清理内存
  • 我通过每一行开始我的循环，比较所有50k行…
  • 如果find了一个dupe行，它被添加到了dupe字典中，所以我们不会在那个行上做同样的过程
  • 当发现这种情况时，P＆Q总数就被添加到该行的P＆Q中
  • 在检查完所有的50k行后，我们把总数放到行的R列中继续前进
  • 如果这个行在dupedict中已经被注意到了，我们跳过它（邪恶的GoTo小心！） 
 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
Interesting Posts

Excel VBA VLookup – 错误13 – “types不匹配”

使用XSSFWorkbook附加到现有的Excel文件

VBA – 任何人都可以解释为什么我与细胞（）的对象错误？

Excel公式最小值的位置

检查重复复制在一个单元格中

openpyxl：从Excel中读取浮点数精度的损失？

在VBA中使用Solver时，如何closures重新计算？

Excel：使用查找function显示值

激活表单button受某些条件的限制

处理超过255个字符的内容：= Cells.find（）的属性