jmm85
02-24-2015, 05:57 AM
Hello all, I've been working on a macro that deletes duplicate rows until it reaches the only of its kind and then adds the quantity of total rows. It does exactly what it is supposed to do, however it takes way too long. I've added a few lines that I have found through some limited searching to expedite the macro, however it still takes too long to run. Could y'all take a look and recommend ways to run through a little quicker? Thanks in advanced.
Sub RemoveDupe()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Count As Integer
Dim Row As Integer
Count = 1
' Set Filter
With ActiveWorkbook.Worksheets("Sheet1")
.AutoFilterMode = False
.Range("M6:AI6").AutoFilter
End With
' Filter in Alphaorder by Name
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields
.Clear
.Add Key:=Range("M6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
End With
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
' Checks if the line below is the same as the line above. If they match, delete the row,
' if they do not match write the number of times the line occured
For Row = Cells(Rows.Count, "M").End(xlUp).Row To 7 Step -1
If Cells(Row, 13).Value = Cells(Row - 1, 13).Value And Cells(Row, 15).Value = Cells(Row - 1, 15).Value Then
Count = Count + 1
Range(Cells(Row, 13), Cells(Row, 36)).Delete (xlShiftUp)
Else
Worksheets("Sheeet1").Range("AJ" & Row) = Count
Count = 1
End If
Next Row
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub RemoveDupe()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Count As Integer
Dim Row As Integer
Count = 1
' Set Filter
With ActiveWorkbook.Worksheets("Sheet1")
.AutoFilterMode = False
.Range("M6:AI6").AutoFilter
End With
' Filter in Alphaorder by Name
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields
.Clear
.Add Key:=Range("M6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
End With
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Sheet1").AutoFilterMode = False
' Checks if the line below is the same as the line above. If they match, delete the row,
' if they do not match write the number of times the line occured
For Row = Cells(Rows.Count, "M").End(xlUp).Row To 7 Step -1
If Cells(Row, 13).Value = Cells(Row - 1, 13).Value And Cells(Row, 15).Value = Cells(Row - 1, 15).Value Then
Count = Count + 1
Range(Cells(Row, 13), Cells(Row, 36)).Delete (xlShiftUp)
Else
Worksheets("Sheeet1").Range("AJ" & Row) = Count
Count = 1
End If
Next Row
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub