PDA

View Full Version : Code Efficiency



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

Ringhal
02-24-2015, 06:12 AM
If you are just deleting duplicates, there's a function in Excel that does it for you.
Also, here is a 1 line VBA code that can do it.

ActiveSheet.Range("$A$1:$A$23").RemoveDuplicates Columns:=1, Header:=xlNo

Paul_Hossler
02-24-2015, 06:18 AM
Can you post a small workbook with the before and after?

Bob Phillips
02-24-2015, 06:38 AM
See if this is faster


Sub RemoveDupe()
Dim rng As Range
Dim cnt As Long
Dim lastrow As Long

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cnt = 1

' Set Filter
With ActiveWorkbook.Worksheets("Sheet1")

.AutoFilterMode = False
.Range("M6:AI6").AutoFilter

' Filter in Alphaorder by Name
With .AutoFilter.Sort.SortFields

.Clear
.Add Key:=Range("M6"), SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
End With

With .AutoFilter.Sort

.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

.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
lastrow = .Cells(.Rows.Count, "M").End(xlUp).Row
.Columns("P").Insert
.Range("P1").Value = "tmp"
With .Range("P2").Resize(lastrow - 1)

.Formula = "=AND(M2=M1,O2=O1)"
.Value = .Value
End With
With .Range("AK2").Resize(lastrow - 1)

.Formula = "=IF(NOT(P2),COUNTIF(P$1:P1,TRUE)-SUM(AK$1:AK1),"""")"
.Value = .Value
End With
Set rng = .Range("P1").Resize(lastrow - 1)
rng.AutoFilter Field:=1, Criteria1:="TRUE"
On Error Resume Next
Set rng = rng.Cells(2, 1).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
.Columns("P").Delete
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

jmm85
02-24-2015, 06:49 AM
Here is a mockup of my file, before and after without code.

apo
02-24-2015, 04:25 PM
Hi..

Here's another that should work pretty fast..

Bumbled my way through this.. still trying to grasp Dictionaries.. snb's website is a life saver.. :)

Note: I have assumed that the real names won't be like "Name 1, Name 2" etc etc.. and that they will be like "Bob, Billy, James" etc

Trying to sort Names that included numbers (like in your sample) was a pain.. so i hope my assumption is correct?



Private Sub CommandButton1_Click()
Dim Z, x, i As Long, cnt As Long
With Range("A1").CurrentRegion
.Sort [A1], 1, , , , , , xlYes
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
Z = Range("A1").CurrentRegion
For i = 2 To UBound(Z)
If Z(i, 1) <> "" Then
If Not .Exists(Z(i, 1)) Then
cnt = 1
.Item(Z(i, 1)) = Z(i, 2) & "|" & Z(i, 3) & "|" & Z(i, 4) & "|" & cnt
Else
cnt = cnt + 1: .Remove Z(i, 1)
.Item(Z(i, 1)) = Z(i, 2) & "|" & Z(i, 3) & "|" & Z(i - (cnt - 1), 4) & "|" & cnt
End If
End If
Next i
x = Application.Transpose(Array(.keys, .items))
Sheets("Sheet1").Cells(2, 1).Resize(.Count).Value = Application.Transpose(.keys)
For i = LBound(x) To UBound(x)
Sheets("Sheet1").Cells(i + 1, 2).Resize(, 4).Value = Split(x(i, 2), "|")
Next i
Sheets("Sheet1").Select
End With
End Sub


One question..

In the sample workbook i have attached.. should the value in Sheet1 (C12) be 3500 or 2000 (after you have clicked the button)..?


If so..

Change this:

.Item(Z(i, 1)) = Z(i, 2) & "|" & Z(i, 3) & "|" & Z(i - (cnt - 1), 4) & "|" & cnt

to this:

.Item(Z(i, 1)) = Z(i, 2) & "|" & Z(i - (cnt - 1), 3) & "|" & Z(i - (cnt - 1), 4) & "|" & cnt

oh.. and turn screen updating off before the code then back on at the end.. i forgot that..

snb
02-25-2015, 02:22 AM
Sub M_snb()
With Sheets("After")
Sheets("before").Cells(1).CurrentRegion.AdvancedFilter 2, , .Cells(30, 1), True
.Cells(30, 1).CurrentRegion.Sort .Cells(30, 2), , , , , , , 1
sn = Split("_" & Join(Application.Transpose(Sheets("before").Cells(1).CurrentRegion.Columns(2)), "_|_") & "_", "|")

sp = .Cells(30, 1).CurrentRegion.Columns(2)
For j = 2 To UBound(sp)
sp(j, 1) = UBound(Filter(sn, "_" & sp(j, 1) & "_")) + 1
Next
.Cells(30, 5).Resize(UBound(sp)) = sp
End With
End Sub