Vba Excel宏以更高效地合并重复单元格和求和相应数据

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

mike  651
mike  115
john  380
bob   225
bob   200

结果将是：

mike  766
john  380
bob   425

该代码适用于较小的数据集，但当我尝试在较大的数据集（大约500000行）上使用它时，代码速度非常慢（运行需要一个多小时）。如何编辑代码以使其足够高效地合并重复项并快速求和一个非常大的数据集的相应数据

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

---

为了快速取得胜利，您可以这样做：

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是什么？如何申报？如果它们是变体，则将它们变长。如果速度仍然很慢，请记下应该删除哪些行，然后一步删除它们。

为了快速获胜，您可以这样做：

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是什么？如何申报？如果它们是变体，则将它们变长。如果速度仍然很慢，请记下应该删除哪些行，然后一步删除它们。

无需循环：

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

无需循环：

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

---

这将对A:B列求和，并将结果放在D1和down中

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

---

在我这端，大约一秒钟的任务是50000行

这将对a:B列求和，并将结果放在D1和down中

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

在我这一方大约一秒钟的时间内处理50000行任务