Code Efficiency

[jmm85]

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]

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]

Can you post a small workbook with the before and after?

[Bob Phillips]

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]

Here is a mockup of my file, before and after without code.

[apo]

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]

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