View Full Version : Delete is taking to long, and I dont know another way to do it.
alphamall
08-26-2016, 10:04 AM
Hello all,
I am new to VBA. I have never used it before, but have been tasked with creating a macro that sorts data on a spreadsheet with over 20k rows. Well either create the macro or do it by hand. So first my thought process. I want to use a for loop to go through each row of my excel sheet. While doing this I will be comparing the row I am on to the row above it. If it is a match then I will delete the above row, and compare the lower row to the next one in line. This is all fine except when I do it I either crash excel or it takes like 8 minutes(if I'm lucky). Without the delete function the code runs rapidly. I had another version where I incremented the amount of rows I check, but still couldn't get rid of the ones I didn't need correctly. I am in excel 2013, and I am desperate any/all help appreciated I will post the code below.
I am only including the section that is giving me a ton of trouble. I believe that this will be enough for someone with actual VBA talent to help. The line I believe is slowing it down in particular is entireRow.delete.
Dim lngRow as Long
Dim lngRows As Long
lngRows = Range("A" & Rows.Count).End(xlUp).Row
For lngRow = lngRows To 2 Step -1
'// Code to determine if row blank...
doneComparing = False
Do While doneComparing = False
If Cells(lngRow, typeCell.Column) = Cells(lngRow, typeCell.Column).Offset(-1, 0) And Cells(lngRow, DateCell.Column) = Cells(lngRow, DateCell.Column).Offset(-1, 0) Then
If (Cells(lngRow, 7).Offset(-1, 0).Value <> "") And Cells(lngRow, 7).Value <> Cells(lngRow, 7).Offset(-1, 0).Value Then
Cells(lngRow, 7) = Cells(lngRow, 7) + Cells(lngRow, 7).Offset(-1, 0)
End If
Rows(lngRow).Offset(-1, 0).EntireRow.Delete
Else
doneComparing = True
End If
Loop
Next
Paul_Hossler
08-26-2016, 10:30 AM
My rule of thumb is to
1. start at bottom and work up in a For I = X to 2 Step -1 loop (like you did)
2. Test cells in I against I-1
3. Combine needed data from I into I-1
4. Delete I (not I-1)
This will likely need (a lot) of tweaking but it should give you a nudge
Option Explicit
Sub Fragment()
Dim lngRows As Long
lngRows = Range("A" & Rows.Count).End(xlUp).Row
For lngRow = lngRows To 2 Step -1
' if I type and I date <> I-1 type and I-1 date
If Cells(lngRow, typeCell.Column) <> Cells(lngRow - 1, typeCell.Column) Then GoTo GetNext
If Cells(lngRow, DateCell.Column) <> Cells(lngRow - 1, DateCell.Column) Then GoTo GetNext
'if Col G is not blank
If (Cells(lngRow, 7).Value <> "") Then
'if G(I) <> (G(I-1)
If Cells(lngRow, 7).Value <> Cells(lngRow - 1, 7).Value Then
'then add G(I) to G(I-1)
Cells(lngRow - 1, 7) = Cells(lngRow - 1, 7) + Cells(lngRow, 7)
End If
'Delete the row we added FROM
Rows(lngRow).Delete
End If
GetNext:
Next
End Sub
1. Since you have a long counter (lngRow), you can use lngRow-1 instead of .Offset (tad faster)
2. Don't think you need the Do Loop
3. Your [Rows(lngRow).Offset(-1, 0).EntireRow.Delete] was messing up the row (I think -- without sample data, I couldn't tell for sure)
alphamall
08-26-2016, 10:43 AM
My rule of thumb is to
1. start at bottom and work up in a For I = X to 2 Step -1 loop (like you did)
2. Test cells in I against I-1
3. Combine needed data from I into I-1
4. Delete I (not I-1)
This will likely need (a lot) of tweaking but it should give you a nudge
Option Explicit
Sub Fragment()
Dim lngRows As Long
lngRows = Range("A" & Rows.Count).End(xlUp).Row
For lngRow = lngRows To 2 Step -1
' if I type and I date <> I-1 type and I-1 date
If Cells(lngRow, typeCell.Column) <> Cells(lngRow - 1, typeCell.Column) Then GoTo GetNext
If Cells(lngRow, DateCell.Column) <> Cells(lngRow - 1, DateCell.Column) Then GoTo GetNext
'if Col G is not blank
If (Cells(lngRow, 7).Value <> "") Then
'if G(I) <> (G(I-1)
If Cells(lngRow, 7).Value <> Cells(lngRow - 1, 7).Value Then
'then add G(I) to G(I-1)
Cells(lngRow - 1, 7) = Cells(lngRow - 1, 7) + Cells(lngRow, 7)
End If
'Delete the row we added FROM
Rows(lngRow).Delete
End If
GetNext:
Next
End Sub
1. Since you have a long counter (lngRow), you can use lngRow-1 instead of .Offset (tad faster)
2. Don't think you need the Do Loop
3. Your [Rows(lngRow).Offset(-1, 0).EntireRow.Delete] was messing up the row (I think -- without sample data, I couldn't tell for sure)
Your solution works, but we are still looking at about 5 minutes of execution time. Is that typical? We are looking at 20k rows with 17 columns. Also want to say thanks for the help. I am so flustered over this.
Paul probaly has the solution. I didn't look.
This code
If (Cells(lngRow, 7).Offset(-1, 0).Value <> "") And Cells(lngRow, 7).Value <> Cells(lngRow, 7).Offset(-1, 0).Value Then
Cells(lngRow, 7) = Cells(lngRow, 7) + Cells(lngRow, 7).Offset(-1, 0)
End If
Rows(lngRow).Offset(-1, 0).EntireRow.Delete
Assuming lngRow is 20, that Sets Cells(20,7) = Cell(20,7) + Cells(19,7) then Deletes Row 19
Then lngRow is set = 19 which is the old row 20 which gets check again.
Is that what you need? If not, then set Cells 19 = 19 + 20 and delete Row 20
Second timing issue. Are there any formulas in your table? Excel must update all of them below the deletion to reflect the change in relevant Row numbers
alphamall
08-26-2016, 01:31 PM
Paul probaly has the solution. I didn't look.
This code
If (Cells(lngRow, 7).Offset(-1, 0).Value <> "") And Cells(lngRow, 7).Value <> Cells(lngRow, 7).Offset(-1, 0).Value Then
Cells(lngRow, 7) = Cells(lngRow, 7) + Cells(lngRow, 7).Offset(-1, 0)
End If
Rows(lngRow).Offset(-1, 0).EntireRow.Delete
Assuming lngRow is 20, that Sets Cells(20,7) = Cell(20,7) + Cells(19,7) then Deletes Row 19
Then lngRow is set = 19 which is the old row 20 which gets check again.
Is that what you need? If not, then set Cells 19 = 19 + 20 and delete Row 20
Second timing issue. Are there any formulas in your table? Excel must update all of them below the deletion to reflect the change in relevant Row numbers
In terms of needing row 20 to be checked again I am a bit confused. I need to grab 20 and check it against 19. If 19 and 20 meet the criteria then add row 19's value to row 20's value. After the values are added row 19 should be deleted. I then need to check row 20 again against the new row 19. Row 20 would have to be checked in this manner until it fails to meet the criteria. Then we would go up to the next row (newest 19 where we failed to match with row 20) and do the same thing. I need to rinse and repeat the this process for the entire sheet. I believe that is what Paul's code does what I need, but I may have to re-verify that info.
There are no formulas in my table.
Thanks again for your help because I am at total loss. It may be worth noting that if i remove 3 of my 17 columns performance increases significantly to about 10 seconds for the entire macro. These columns do not have any formulas or styling, but do have text and dates. so I am at a loss.
Paul_Hossler
08-26-2016, 02:31 PM
Very simple demo
Option Explicit
Sub ProofOfConcept()
Dim r As Range
Dim i As Long, lstRow As Long
Set r = Worksheets("sheet1").Cells(1, 1).CurrentRegion
lstRow = r.Rows.Count
For i = lstRow To 3 Step -1
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Cells(i - 1, 2).Value = Cells(i - 1, 2).Value + Cells(i, 2).Value
Rows(i).Delete
End If
Next i
End Sub
I need to grab 20 and check it against 19.
If 19 and 20 meet the criteria then add row 19's value to row 20's value.
After the values are added row 19 should be deleted.
I then need to check row 20 again against the new row 19.
Row 20 would have to be checked in this manner until it fails to meet the criteria.
Then we would go up to the next row (newest 19 where we failed to match with row 20) and do the same thing.
I need to rinse and repeat the this process for the entire sheet
What my code does is sort of similar and BASED ON MY UNDERSTANDING OF WHAT YOU WANT TO DO
You might have to change some tests, etc.
Changing a few words
I need to grab 20 and check it against 19.
If 19 and 20 meet the criteria then add row 20's value to row 19's value.
After the values are added row 20 should be deleted.
I then need to check row 19 against the new row 18.
I need to rinse and repeat the this process for the entire sheet
row 19 should be deleted. I then need to check row 20 again against the new row 19. Row 20 would have to be checked in this manner until it fails to meet the criteria.
You must mean "Check the new Row 19, (the old 20,) against the pre-existing Row 18"
Words have meanings and meaning affect logic.
Only 17 Columns? Piece O' Cake. Just need to know exactly which columns need to be compared.
'Optimised for speed
Dim arCheck
Dim ThisRow As Range
Dim arTheseValues
Dim arCheckValues
Dim i As Long
Dim c As Long
Application.ScreenUpdating = False
arCheck = Array( Column Numbers to check go here ) 'Ex: (3, 5, 9, 15, 16)
Set ThisRow = Cells(Rows.Count, "A").End(xlUp).Resize(, 17)
Do While ThisRow.Row > 2
arTheseValues = ThisRow.Value
Do 'this loop runs until inequality found
Set arCheckValues = ThisRow.Offset(-1).Value
For i = Lbound(arCheck) to Ubound(arCheck)
c= arCheck(i)
If arTheseValues(c) <> arCheckValues (c) Then Exit Do
Next i
With ThisRow.Cells(7)
.Value = .Value + arCheckValues(7)
End With
ThisRow.Offset (-1).EntireRow.Delete
Loop
Set ThisRow = ThisRow.Offset(-1)
Loop
Application.ScreenUpdating = True
Paul_Hossler
08-26-2016, 05:28 PM
Based on the original post
If Cells(lngRow, typeCell.Column) = Cells(lngRow, typeCell.Column).Offset(-1, 0) And Cells(lngRow, DateCell.Column) = Cells(lngRow, DateCell.Column).Offset(-1, 0) Then
If (Cells(lngRow, 7).Offset(-1, 0).Value <> "") And Cells(lngRow, 7).Value <> Cells(lngRow, 7).Offset(-1, 0).Value Then
Cells(lngRow, 7) = Cells(lngRow, 7) + Cells(lngRow, 7).Offset(-1, 0)
End If
it look like the typeCell column, the DateCell column, and column 7 are the only 3 columns being compared between rows
Are TypeCell and DateCell Excel 2007 Functions or UDFs? I see no mention of them in Excel XP.
No. They can't be, the syntax is wrong, more like an Object Method or Property. They're not mentioned in VBA XP either.
Got it! Named Ranges.
Paul, if you're right about only checking two columns three loops will churn thru that in a heartbeat.
Start second from the bottom in the TypeCell Column
Do While Row > 1
Do While TypeCell & DateCell = Offset(1) DateCell & TypeCell
Sum and delete Offset(1) Entire Row
Offset (-1)
Loop
Do while TypeCell & DateCell <> Offset(1) DateCell & TypeCell
Offset (-1)
Loop
Loop
Just put the most common encountered inner loop first.
1. Avoid reading/writing in worksheets
2. Avoid inserting/deleting rows/columns in Worksheets
3. avoid calculating/working in ranges
4. use arrays instead
5. always provide a sample file
6. do not quote previous posts
Based on PH's example file
Sub M_snb()
sn = Sheet1.Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = .Item(sn(j, 1)) + sn(j, 2)
Next
Sheet2.Cells(1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
End With
End Sub
If you want to write more then 2 columns and want to sum the values in column G (=column 7):
Sub M_snb()
sn = Sheet1.Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
st = Application.Index(sn, j)
If .exists(sn(j, 1)) Then st(7) = .Item(sn(j, 1))(7) + st(7)
.Item(sn(j, 1)) = st
Next
Sheet2.Cells(10, 1).Resize(.Count, ubound(sn,2)) = Application.Index(.items, 0, 0)
End With
End Sub
Paul_Hossler
08-27-2016, 06:35 AM
5. always provide a sample file
+100
That way we don't need to make SO many assumptions and guesses
However, since the OP does want to delete rows, you will need to interact with the worksheet
This is what always irks me
I am new to VBA. I have never used it before . . . I am only including the section that is giving me a ton of trouble.
I'm having trouble with my truck. I'm not a mechanic.
It will start but it smokes a lot and as soon as I put it in gear it dies. Here is what I think the problem is. How do I fix it?
16954
You might do some inflating ??
Paul_Hossler
08-27-2016, 01:29 PM
@alphamall --
if it takes too long, it might be from manipulating the WS objects a lot
try the 2 changes marked and see
Option Explicit
Sub Fragment_1()
Dim lngRows As Long
lngRows = Range("A" & Rows.Count).End(xlUp).Row
For lngRow = lngRows To 2 Step -1
' if I type and I date <> I-1 type and I-1 date
If Cells(lngRow, typeCell.Column) <> Cells(lngRow - 1, typeCell.Column) Then GoTo GetNext
If Cells(lngRow, DateCell.Column) <> Cells(lngRow - 1, DateCell.Column) Then GoTo GetNext
'if Col G is not blank
If (Cells(lngRow, 7).Value <> "") Then
'if G(I) <> (G(I-1)
If Cells(lngRow, 7).Value <> Cells(lngRow - 1, 7).Value Then
'then add G(I) to G(I-1)
Cells(lngRow - 1, 7) = Cells(lngRow - 1, 7) + Cells(lngRow, 7)
End If
'mark the row we added FROM
Cells(lngRow, 7).Value = True '-------------------------
End If
GetNext:
Next
Columns(7).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete '----------------------------
End Sub
@PH
deleting rows =functionally equivalent to filtering 'parts' of 'rows' e.g.
sn=range("A1:K10")
sp=application.index(sn, application.transpose(array(1,3,5,7)),[transpose(row(1:10))])
Paul_Hossler
08-28-2016, 06:07 AM
The other parts are actually deleting the rows after combining values
I could make it work using arrays and/or filtering, but for the OP I suggested the simplest, most Excel-like approach
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.