Excel宏可以合并重复的单元格并更有效地汇总相应的数据

时间:2016-06-23 14:45:22

标签: excel vba excel-vba

我有以下代码,它合并重复的单元格,然后对其他列中的相应单元格求和。例如,如果我有:

mike  651
mike  115
john  380
bob   225
bob   200

结果输出为:

mike  766
john  380
bob   425

该代码适用于较小的数据集,但是当我尝试在较大的数据集(大约500,000行)上使用它时,代码非常慢(需要花费一个多小时来运行)。如何编辑我的代码以使其足够有效地合并重复项并快速汇总非常大的数据集的相应数据?

Sub mergeDups()

lastRow = ActiveSheet.UsedRange.Rows.Count
Set r = ActiveSheet.UsedRange.Resize(1)
With Application.WorksheetFunction

    For iRow = lastRow - 1 To 2 Step -1
        Do While Cells(iRow, 1) = Cells(iRow + 1, 1)
            LastCol = r(r.Count).Column
            SumCol = LastCol + 1
               For iCol = 2 To SumCol
               Cells(iRow, iCol) = .Sum(Range(Cells(iRow, iCol), Cells(iRow + 1, iCol)))
               Next iCol
            Rows(iRow + 1).delete
        Loop
    Next iRow

End With

End Sub

3 个答案:

答案 0 :(得分:2)

只是为了获得快速胜利 - 你可以这样做:

Sub mergeDups()

    call OnStart

    lastRow = ActiveSheet.UsedRange.Rows.Count
    Set r = ActiveSheet.UsedRange.Resize(1)
    With Application.WorksheetFunction

        For iRow = lastRow - 1 To 2 Step -1
            Do While Cells(iRow, 1) = Cells(iRow + 1, 1)
                LastCol = r(r.Count).Column
                SumCol = LastCol + 1
                   For iCol = 2 To SumCol
                   Cells(iRow, iCol) = .Sum(Range(Cells(iRow, iCol), Cells(iRow + 1, iCol)))
                   Next iCol
                Rows(iRow + 1).delete
            Loop
        Next iRow

    End With
    call OnEnd

End Sub

Public Sub OnStart()

    Application.AskToUpdateLinks = False
    Application.ScreenUpdating = False
    Application.Calculation = xlAutomatic
    Application.EnableEvents = False
    Application.DisplayAlerts = False

End Sub

Public Sub OnEnd()

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.StatusBar = False
    Application.AskToUpdateLinks = True

End Sub

此外 - LastRow和iRow是什么?他们是如何宣布的?如果它们是变体,那么让它们变长。如果它仍然很慢,请记下应删除哪些行并一步删除它们。

答案 1 :(得分:2)

不需要循环:

Sub merge()
Dim rng As Range
Dim ws As Worksheet

Set ws = ActiveSheet

With ws
    Set rng = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
    rng.Offset(, 50).FormulaR1C1 = "=SUMIF(C1,RC[-51],C2)"
    rng.Value = rng.Offset(, 50).Value
    rng.Offset(, 50).ClearContents
    rng.Offset(, -1).Resize(, 2).RemoveDuplicates 1, xlGuess
End With

End Sub

答案 2 :(得分:2)

这将对A列和B列进行求和,并将结果放在D1和向下。

Sub mergeDups()
    lastRow = ActiveSheet.UsedRange.Rows.Count
    Range("D1").Consolidate Sources:=Array("R1C1:R" & lastRow & "C2"), LeftColumn:=True, Function:=xlSum
End Sub

在我的最后用50,000行播放大约一秒