Slow macro due to Copy and Paste Special

dylandrush · May 9th 2012

Hello,

I wrote a macro which is probably horribly inefficient, but it gets the job done. The macro can take up to 30min to run... It has to go through about 650 cells look to see if there is a duplicate, if there is it highlights them with a color and copies the data and pastes it above. after all of the highlighting, another macro runs, filters for the color and deletes the entire row with that color. Because the macro takes so long, I figured that I would try to make it more efficient. I saw from a quick google search, that i should try to avoid copy and paste special as much as possible, so I got ride of the copy and paste special and replaced it with a range1.value = range2.value. I got that to work no problem, but it didn't really help performance at all. I need the cells to preserve their formatting...

Here is the code that I wrote:

Code

Option Private Module




Sub findDups()




'*****************************************************************************************************************************
'* This macro finds duplicate cells and highlighs all but the first one a blueish colour.  It also takes the value from the
'* various columns in the highlighted cell's row and moves it into the the cell above it.  It will keep moving
'* the cell up untill it reaches the first non highlighted cell in a the list of duplicates.  The reason for this
'* is because it highlightes the newest occurence of the duplicate.  The newest occurence has the most recent
'* data.  I can't delete the oldest occurence because the oldest occurence contains manually entered data and
'* cell formatting that we want to preserve.
'*****************************************************************************************************************************
   Dim amount As Double
   Dim count As Integer
   Dim percentage As Double
   
   percentage = 0
   count = 0
   
   On Error GoTo Continue:
    ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear
Continue:
    Range("A1:S1").Select
    Selection.AutoFilter
    ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
        "A1:A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    amount = Application.WorksheetFunction.CountA(Range("A:A"))
   
   Range("A1").Activate
   FirstItem = Range("A1")
   SecondItem = Range("A1").Offset(1, 0).Value
   Offsetcount = 1
   Do While ActiveCell <> ""
      If FirstItem = SecondItem Then
      
        ActiveCell.Offset(Offsetcount, 0).Interior.Color = RGB(7, 18, 91)
        
       Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 11)).Value = _
           Range(ActiveCell.Offset(Offsetcount, 1), ActiveCell.Offset(Offsetcount, 11)).Value




        
        'Range(ActiveCell.Offset(Offsetcount, 1), ActiveCell.Offset(Offsetcount, 11)).Copy
        'ActiveCell.Offset(0, 1).PasteSpecial _
        '    Paste:=xlPasteValues, _
        '    Operation:=xlNone, _
        '    SkipBlanks:=False, _
        '    Transpose:=False
        'ActiveCell.Offset(0, -1).Activate
           
        Offsetcount = Offsetcount + 1
        SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
      Else
        ActiveCell.Offset(Offsetcount, 0).Select
        FirstItem = ActiveCell.Value
        SecondItem = ActiveCell.Offset(1, 0).Value
        Offsetcount = 1
      End If
      
      count = count + 1
      percentage = (count / amount) * 85
      Process_Dialogue.ProgressBar1.Value = percentage
      Process_Dialogue.lblPercent.Caption = Str(Round(percentage, 2)) & " %"
      DoEvents
      
   Loop




End Sub

Display More

Any tips on how to improve the code would be greatly appreciated!

Thanks,
-Dylan

dangle · May 9th 2012

Re: Slow macro due to Copy and Paste Special

Dylan

There could be a number of ways to do this, maybe even just using Excel depending on how your data is set up and if the solution does not have to be a macro.

Can you upload a small sample workbook with original data and desired output?

What version of Excel are you using?

_lh · May 9th 2012

Re: Slow macro due to Copy and Paste Special

I'm not sure why you need to highlight the duplicate cells unless it's just to go back and delete them afterwards, or I'm misunderstanding your question.

If you have no other data in column A then the best way to remove all the duplicates might be something like the following. It inserts a new column, uses AdvancedFilter to copy across just the unique values to that column then deletes the original one:

Code

Sub RemoveDuplicates()
    Columns("A:A").EntireColumn.Insert
    Range("B1", Range("B1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
    Columns("B:B").EntireColumn.Delete
End Sub

dylandrush · May 11th 2012

Re: Slow macro due to Copy and Paste Special

I am using excel 2007. I've attached a document and hopefully have sufficiently explained in it what I am trying to do. Thanks for the help and quick responses!

dylandrush · May 17th 2012

Re: Slow macro due to Copy and Paste Special

Well, I was able to fix the problem myself. i added

Code

Application.Calculation = xlCalculationManual


    '   My code here


   Application.Calculation = xlCalculationAutomatic

That cut the time down from 30+ minutes to just a minute.

Slow macro due to Copy and Paste Special

Participate now!

Share