Macro efficiency - Execute process faster

Hello all... again!!

I have a macro, that works totally fine, it is just SLOW AS HECK!!

here is the situation, and maybe what I already have is the best it can do... I just don't want to believe it though.. lol

ok.. I have a spreadsheet that has OVER 150000 rows, some of these rows have a duplicated value in a column (Column 'C').

I have this macro that steps backward from the bottom removing the duplicated rows based on that value, but before it does, it copies
the value from Column 'I' and pastes it into column 'G', then it will delete the original duplicate row.

it all works, but since I am not the VBA god as MANY on here, I was wondering for future knowledge if this could be written to be more efficient.

Thanks, and the code is below...

Sub DeleteDuplicateRows()

' ** Deletes duplicate Rows based on duplicated Value in Column 'C' and copies
' ** the total value of the duplicate rows from Column 'I' and pastes
' ** into Column 'G' before deleting the duplicate

Dim rng As Range
Dim counter As Long
Dim LastRow As Long

Application.ScreenUpdating = False

' ** Find Last Row with data based on Column 'C'
LastRow = Range("C1000000").End(xlUp).Row


With ActiveSheet
    Set rng = ActiveSheet.Range("C1:C" & LastRow)
End With

' ** Loops through each row starting at the last row with data and working up to the first row
For counter = LastRow To 1 Step -1

    If rng.Cells(counter) Like rng.Cells((counter) - 1) Then
    
       ' ** Copies the value from Column 'I' and pastes value into Column 'G' of same Row
       Range("I" & ((counter) - 1)).Copy
       Range("G" & ((counter) - 1)).PasteSpecial Paste:=xlPasteValues
       ' ** Deletes the copied value from Column 'I'
       Range("I" & ((counter) - 1)).ClearContents
       
       Application.CutCopyMode = False
    
       ' ** Deletes the Duplicate Row based on the Value in Column 'C'
       rng.Cells(counter).EntireRow.Delete
        
    End If
    
Next

End Sub

try

Sub xxx()

Dim r As Long, c As Long, i As Long
Dim a, s, u()

r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
ReDim u(1 To r, 1 To 1)
a = Cells(1).Resize(r + 1, c)

For i = 2 To r
    If a(i, 3) = a(i - 1, 3) Then
        s = s + 1
        u(i, 1) = 1
        a(i - 1, 7) = a(i - 1, 9): a(i - 1, 9) = ""
    End If
Next i

If s > 0 Then
    Cells(1).Resize(r + 1, c) = a
    Cells(c + 1).Resize(r) = u
    Cells(1).Resize(r, c + 1).Sort Cells(c + 1), Header:=xlNo
    Cells(1).Resize(s, c + 1).Delete xlUp
End If

End Sub

kalak,

That was a ton faster.. I didn't even have to get up and walk away from the desk when it was executed.

now, since this is a huge learning opportunity for me, could you further explain or breakdown the code so I can understand how it is working?

if you have the time...

I will no doubt have many more uses for it as I regularly have worksheets with close to the maximum rows of data to consolidate and would like to understand further.

Originally Posted by Zoediak

... could you further explain or breakdown the code so I can understand how it is working?

here's an annotated version of that code

Sub xxx_annotated()
'Purpose is to delete adjoining rows with duplicate values in ColC,
'retaining only one such row, and
'to copy the value in ColumnI of remaining duplicate row to Col G and then delete Col I value

'Declare the variables to be used
Dim r As Long, c As Long, i As Long
Dim a, s, u()

'Obtain the last row and last column of the used region of the worksheet
r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column

'define the size of the (memory) array later used
'to to mark the rows with duplicates in ColC
ReDim u(1 To r, 1 To 1)

'Put the values of the worksheet data array into
'a memory array for (usually) faster manipulations
a = Cells(1).Resize(r + 1, c)
'the above line can be optionally written a = Cells(1).Resize(r + 1, c).Value
'to maybe remind the user that it refers only to values and not to formats etc.
'the .Value can however be omitted by default

'loop though the memory array to find the number of duplicates in ColC, i.e. s
'also to mark in the u() array  those rows in which duplicates occur in ColC
'also does the requested swap (in memory array) of relevant values in cols G and I
For i = 2 To r
    If a(i, 3) = a(i - 1, 3) Then
        s = s + 1
        u(i, 1) = 1
        a(i - 1, 7) = a(i - 1, 9): a(i - 1, 9) = ""
    End If
Next i

'If number of duplicates in ColC is > 0 then
'list the data array with swapped relevant values of Cols G and I back onto the worksheet
'list the array u() (with duplicate rows marked with 1) into an additional used column
'sort all used rows in the worksheet by the column where duplicates marked
'delete all rows where duplicates occurred as one block
'this is much faster than the row-by-row deletion that is so commonly done, and
'was the main reason your own code was so slow.
If s > 0 Then
    Cells(1).Resize(r + 1, c) = a
    Cells(c + 1).Resize(r) = u
    Cells(1).Resize(r, c + 1).Sort Cells(c + 1), Header:=xlNo
    Cells(1).Resize(s, c + 1).Delete xlUp
End If

End Sub

Kalak,

Thank you for the annotations... This will help me out a lot!!

Originally Posted by pjwhitfield

A really little one that might save a little time is to not copy/paste the I value but simply place it in the cell ie

Range("G" & ((counter) - 1)).value = Range("I" & ((counter) - 1)).value

I base this on nothing other than the belief that Copy/Paste must be more intensive than = plus it loses 2 lines of code.

Alternatively, you could CUT the value from I and therefore remove the need for the .ClearContents line

pjwhitfield,

I did incorporate your option as well on my test sheet.

It did reduce the execute time by a little and I do see your point on the reasoning for the suggestion.

Thank you..

This VBA stuff... always seems like there is something new to learn... I love it!