Reputation: 1
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
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
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