Delete is taking to long, and I dont know another way to do it.

[alphamall]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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]

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?
180px-FirestoneTire.jpg

[snb]

You might do some inflating ??

[SamT]

[Paul_Hossler]

@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]

@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]

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