My code crashes when it tries to filter parts or large spreadsheets

[BrianG86]

Hi all,

I have the below code, it opens several different spreadsheets, applies some formula and filters out duplicates and copies all that data to a new workbook.

Every time it goes to filter out the duplicates on the larger sheets, it crashes.

Can anyone help?

Sub HighlightDupes()'


Dim wb As Workbook
Dim ws As Worksheet
Dim strF As String, strP As String
Dim p1 As String
Dim tws As Worksheet
Dim twb As Workbook


    For i = 2 To 19
    
    Set twb = ThisWorkbook
    Set tws = ThisWorkbook.Sheets(2)
    p1 = tws.Range("$b" & i).Value
    strP = "P:\08. CaseBlocks Data for Reports\Stephanie"
    strF = Dir(strP & "\" & p1 & ".xlsx")
    
    Application.ScreenUpdating = False
        
    Set wb = Workbooks.Open(strP & "\" & strF, UpdateLinks:=3, ReadOnly:=True)
    Range("a1").Select
    Range(Selection, Selection.End(xlDown)).Select
    c = Selection.Count
    
    Cells.Select
    Selection.NumberFormat = "General"
    
    Columns("O:Q").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("O2:O" & c).FormulaR1C1 = "=clean(trim(rc[-1]))"
    Range("p2:P" & c).FormulaR1C1 = "=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(rc[-1],""/"",""""),"" "",""""),""-"",""""),""("",""""),"")"",""""),""'"","""")"
    Range("Q2:Q" & c).FormulaR1C1 = "=CONCATENATE(LEFT(rc[-16],10),rc[-1])"
    
    Rows("1:1").AutoFilter
    Columns("Q:Q").Select
        Selection.FormatConditions.AddUniqueValues
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        Selection.FormatConditions(1).DupeUnique = xlDuplicate
        With Selection.FormatConditions(1).Font
            .Color = -16383844
            .TintAndShade = 0
        End With
        With Selection.FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 13551615
            .TintAndShade = 0
        End With
        Selection.FormatConditions(1).StopIfTrue = False
        ActiveSheet.Range("$A$1:$X$18").AutoFilter Field:=17, Criteria1:=RGB(255, _
            199, 206), Operator:=xlFilterCellColor
            
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    lastRow = Selection.Count
    Range("A2:CL" & lastRow).Copy


    ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial




    Application.CutCopyMode = False
    wb.Close False
    
    
    Next
    
    Application.ScreenUpdating = True
        
    End Sub

 

[dermie_72]

instead of Selection.FormatConditions(1).DupeUnique = xlDuplicate
try

Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

 

[BrianG86]

Hi dermie

This isn't working

It just takes the filter off and nothing is filtered out.

Any other suggestions?

Thanks

 

[BrianG86]

Is there a quicker way to filer for duplicate values?

Even when I do this without VBA it takes a few seconds to filter, so I am hoping there is a quicker way?

 

[dermie_72]

there is the remove duplicates function in the data section. You could see if that is any faster.

 

[BrianG86]

Hi Dermie

Thanks for the response, I was looking to keep only duplicates and get rid of anything else.

But I just ran this over the weekend and it worked fine.

Thanks for your help though