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

时间：2011-08-23 12:22:12

标签： excel excel-vba 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个新的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匹配等等

对于整个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行中复制公式的问题。有人可以优化代码吗？

4 个答案:

答案 0 :(得分：3)

对于如何添加重复项，必定会出现严重错误。由于您对所使用数据的详细信息不足，我不知道这是否相同，但我填写了A1：O33334（超过500k的单元格），随机数介于1到10,000之间。

使用字典对象（我以我的爱和过度使用而闻名），我浏览了所有这些并仅将重复值相加，然后将唯一的元素列表打到了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 :(得分：2)

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

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

Sheets(Sheet).Range(TargetCol1 & CStr(StartRow)).Select
Selection.Copy
永远不会粘贴

有关性能问题，请参阅此主题中的一些提示：Benchmarking VBA Code

答案 2 :(得分：1)

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

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

使用连接功能在数据集右侧创建新列。例如

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

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

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

在上面的代码中，aa2指的是该行的连接列。上述结果是您现在标记了所有重复项。现在使用“数据”菜单中的过滤器工具创建排序或过滤器以满足您的分组需求。要添加值，请使用DSum。要删除重复项，请使用高级过滤器。祝你好运。

答案 3 :(得分：0)

我将此作为第二个答案添加，因为它会变得很长......

因为我是一个顽固的骡子，我尝试了很多不同的东西，我认为你已经达到了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单元格转换为变体数组（.2秒）
  • 我抛弃了P＆amp; Q行变为类似的变体数组以供以后使用
  • 我从变体数组中创建了一个包含50,000个字符串（行）的数组（只有1秒左右！）
  • 我告别庞大的变种数组以清理内存
  • 我开始遍历每一行，与所有50k行进行比较......
  • 如果找到一个欺骗行，它会被添加到欺骗词典中，因此我们不会在该行上执行相同的处理
  • 当发现欺骗时，它的P＆amp; Q总数被添加到有问题行的P＆amp; 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
相关问题
最新问题