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

Question

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).

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.

Which bit is slow? You may want to have a look at this: http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros — Skip Intro, Oct 31 '16 at 15:57
Do you just need the sum or do you need the data sorted? Also, 15k rows isn't that big... What's making this so time-intensive? — John Bustos, Oct 31 '16 at 15:58
Try Range.RemoveDuplicates. Looking at your code, I think that calling Row.Delete for individual Rows must be the bottleneck. — z32a7ul, Oct 31 '16 at 16:00
Or read the whole thing into an Array of Variants, write a custom function to sort your data and remove duplicates from this array and write back the data into Range.Value — z32a7ul, Oct 31 '16 at 16:02

score 1 · Answer 1 · edited May 23 '17 at 10:30

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

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

    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 sumif into the value column.

Hope it was helpful.

score 0 · Answer 2 · answered Oct 31 '16 at 16:34

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

Many thanks for response and the tips, but how much time would it save? — user3534838, Nov 02 '16 at 13:34
Depending on how much time your application runs, but I would estimate about 40% - 80%. — Vityata, Nov 02 '16 at 14:45
Great, I have now updated the code as per your suggestion but getting some errors, on the Sorting code "Cells.Select......" it gives me the Run time error 1004. Application-defined or object defined error. Can you please assist. — user3534838, Nov 03 '16 at 09:49

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

2 Answers2