vba Excel - 按列分组的宏和大范围（15K 行）的总和值

Excel - A macro to group by column & sum values for big Range (15K rows)

提问by user3534838

I have an excel sheet with 2 columns and can have upto 15K rows. I need to sum values, group by first and second column. Currently I am using the followinn macro, the code is copying the data across a new sheet, sorting it and removing the duplicates while adding the count if a match found. I have tested it for 500 rows items to so far and it takes couple of minutes and I am worried of the time taken if there are more rows (as there can be up to 15K rows).

我有一个 2 列的 Excel 工作表，最多可以有 15K 行。我需要对值求和，按第一列和第二列分组。目前我正在使用 followinn 宏，代码正在将数据复制到新工作表中，对其进行排序并删除重复项，同时添加计数（如果找到匹配项）。到目前为止，我已经测试了 500 行项目，这需要几分钟，我担心如果有更多行（因为最多可以有 15K 行）所花费的时间。

Sub consolidateData()   

Dim lRow As Long   
Dim ItemRow1, ItemRow2 As String   
Dim lengthRow1, lengthRow2 As String   

    Columns("A:C").Select   
    Selection.Copy   

    Sheets("Sheet3").Select   

    Range("A1").Select   
    ActiveSheet.Paste   

    Cells.Select   
    Selection.Sort _   
        Key1:=Range("A2"), Order1:=xlAscending, _   
        Key2:=Range("C2"), Order2:=xlDescending, _   
        Header:=xlYes, OrderCustom:=1, _   
        MatchCase:=False, Orientation:=xlTopToBottom, _   
        DataOption1:=xlSortNormal   

    lRow = 2   
    Do While (Cells(lRow, 1) <> "")   

        ItemRow1 = Cells(lRow, "A")   
        ItemRow2 = Cells(lRow + 1, "A")   

        lengthRow1 = Cells(lRow, "C")   
        lengthRow2 = Cells(lRow + 1, "C")   

        If ((ItemRow1 = ItemRow2) And (lengthRow1 = lengthRow2)) Then   
            Cells(lRow, "B") = Cells(lRow, "B") + Cells(lRow + 1, "B")   
            Rows(lRow + 1).Delete   

        Else   
            lRow = lRow + 1   
        End If   
    Loop   
End Sub

Could you please suggest if there is a quickest way to do it. Thanks in Advance.

您能否建议是否有最快的方法来做到这一点。提前致谢。

回答by Evis

Thera are a few things you would do to improve your performance:

Thera是一些你会做的事情来提高你的表现：

There is a RemoveDuplicamethod you could use, as of SOF Delete all duplicate row:

有一个RemoveDuplica你可以使用方法中，随着SOF删除所有重复的行：

    Sub DeleteRows()
        With ActiveSheet
          Set Rng = Range("A1", Range("B1").End(xlDown))
          Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        End With
    End Sub

If you use Preformated table it will be easy to fill up a new sheet with the information you need

如果您使用预先格式化的表格，将很容易用您需要的信息填写新表格

When apropriate, always use the code below to improve your funcion/sub performance:

如果合适，请始终使用以下代码来提高您的功能/子性能：

    Application.ScreenUpdating = False

Might be better if you copy only the columns that should be grouped by, then you do the sumifinto the value column.

如果您只复制应该分组的列，那么您将sumif 执行到值列中可能会更好。

Hope it was helpful.

希望它有帮助。

回答by Vityata

This is a quick way to have your macro faster. It would stop animation and a few other perks. :) However, it would be a great idea to rebuild your code from the beginning, avoinding the selects.

这是让您的宏更快的快速方法。它会停止动画和其他一些好处。:) 但是，从头开始重新构建代码是一个好主意，避免选择。

Sub consolidateData()   

    Dim lRow As Long   
    Dim ItemRow1, ItemRow2 As String   
    Dim lengthRow1, lengthRow2 As String   

        call onstart
        Columns("A:C").Select   
        Selection.Copy   

        Sheets("Sheet3").Select   

        Range("A1").Select   
        ActiveSheet.Paste   

        Cells.Select   
        Selection.Sort _   
            Key1:=Range("A2"), Order1:=xlAscending, _   
            Key2:=Range("C2"), Order2:=xlDescending, _   
            Header:=xlYes, OrderCustom:=1, _   
            MatchCase:=False, Orientation:=xlTopToBottom, _   
            DataOption1:=xlSortNormal   

        lRow = 2   
        Do While (Cells(lRow, 1) <> "")   

            ItemRow1 = Cells(lRow, "A")   
            ItemRow2 = Cells(lRow + 1, "A")   

            lengthRow1 = Cells(lRow, "C")   
            lengthRow2 = Cells(lRow + 1, "C")   

            If ((ItemRow1 = ItemRow2) And (lengthRow1 = lengthRow2)) Then   
                Cells(lRow, "B") = Cells(lRow, "B") + Cells(lRow + 1, "B")   
                Rows(lRow + 1).Delete   

            Else   
                lRow = lRow + 1   
            End If   
        Loop   
        call onende
    End Sub


    Public Sub OnEnd()

        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.AskToUpdateLinks = True
        Application.DisplayAlerts = True
        Application.Calculation = xlAutomatic
        ThisWorkbook.Date1904 = False

        Application.StatusBar = False

    End Sub

    Public Sub OnStart()

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

        ActiveWindow.View = xlNormalView

    End Sub