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:
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