PDA

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.

SamT
08-26-2016, 12:10 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

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

SamT
08-26-2016, 02:47 PM
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.

SamT
08-26-2016, 03:19 PM
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

SamT
08-26-2016, 08:26 PM
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.

snb
08-27-2016, 06:00 AM
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

SamT
08-27-2016, 07:58 AM
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

snb
08-27-2016, 10:08 AM
You might do some inflating ??

SamT
08-27-2016, 12:34 PM
:)

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

snb
08-28-2016, 01:31 AM
@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