VBA Macro running so slow it crashes

[BrianG86]

Hi,

I have a macro that I have written (below) that extracts data from several different workbooks after entering some formula and collates them together into one workbook.

The data sets are huge though, with some over 200,000 rows long. It causes it to run really slowly and eventually it will crash.

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




                                               On Error Resume Next
        
        Application.ScreenUpdating = False
        


    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")
    
    
        
    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:R").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])"
        Range("R2:R" & c).Formula = "=countif(Q:Q,Q2)"
    
        ActiveSheet.Rows("1:1").AutoFilter Field:=18, Criteria1:=Array( _
        "2", "3", "4", "5", "6", "7", "8", "9", "10", "11"), Operator:=xlFilterValues
        
        
        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

Does anyone know how I can make this go faster?

 

[BrianG86]

It seems to be when I get to the 4th formula in the big workbooks that it crashes.

Can someone have a look?

 

[JackDanIce]

Had a quick look and tried to optimise it where I could see quick wins, see if this runs any faster:

Sub HighlightDupes() '

Dim wb As Workbook, twb As Workbook
Dim ws As Worksheet, tws As Worksheet
Dim strF As String, p1 As String
        
Set twb = ThisWorkbook
Set tws = twb.Sheets(2)
        
Const strP As String = "P:\08. CaseBlocks Data for Reports\Stephanie"
        
Application.screenUpdating = False

On Error Resume Next
        
For i = 2 To 19
    p1 = tws.Range("$B" & i).Value
    strF = Dir(strP & "\" & p1 & ".xlsx")
    
    Set wb = Workbooks.Open(strP & "\" & strF, UpdateLinks:=3, ReadOnly:=True)

    c = Range("A" & Rows.Count).End(xlUp).Row
    Cells.NumberFormat = "General"
    
    Columns("O:R").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 = "=LEFT(RC[-16],10) & RC[-1]"
    Range("R2:R" & c).Formula = "=COUNTIF(Q:Q,Q2)"
    ActiveSheet.Calculate
    Rows("1:1").AutoFilter Field:=18, Criteria1:=Array("2", "3", "4", "5", "6", "7", "8", "9", "10", "11"), Operator:=xlFilterValues
    
    Range("A2:CL" & c).Offset(1).Resize(c - 1).SpecialCells(xlCellTypeVisible).Copy
    
    twb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
        
    wb.Close False

Next i
    
On Error GoTo 0

Application.screenUpdating = True

Set twb = Nothing: Set wb = Nothing: Set ws = Nothing: Set tws = Nothing

End Sub

 

[BrianG86]

Hi, its not working

It is just that last formula. Why is it crashing excel?

[COLOR=#333333]Range("R2:R" & c).Formula = "=COUNTIF(Q:Q,Q2)"[/COLOR]

 

[JackDanIce]

No idea, you could refine the formula a little further and change that line to:

Range("R2:R" & c).Formula = "=COUNTIF($Q$2:$Q$" & c & "Q2)"