CODEWITHSUNDEEP
vbaexcelmacros
user3534838
user3534838

Reputation: 1

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

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.

Upvotes: 0

Views: 6701

Answers (2)

Vityata
Vityata

Reputation: 43595

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

Upvotes: 0

Evis
Evis

Reputation: 561

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.

Upvotes: 1

Related Questions