How can I speed up this loop

Question

I have a Vba code that is very slow on 25 sheets, I am wondering if this code can be speeded up in any way

Sub Obracun_place_OLP_NEAKTIVNO()
    '
    ' Obracun_place_NOVI Makronaredba
    '
    Call Refresh_neto_TM
    Application.ScreenUpdating = False
        Sheets("PODUZEĆE_PLAĆA").Select
        Range("B7:H7").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.ClearContents
        Sheets("Neto plaća").Select
        ActiveSheet.ListObjects("Tablica_Upit_iz_MS_Access_Database_14").Range. _
            AutoFilter Field:=204, Criteria1:=Range("A2")
        ActiveSheet.ListObjects("Tablica_Upit_iz_MS_Access_Database_14").Range. _
            AutoFilter Field:=207, Criteria1:="<>"
        Range("GV11:GZ11").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("PODUZEĆE_PLAĆA").Select
        Range("B6:F6").Select
        ActiveSheet.Paste
        Sheets("Neto plaća").Select
        Range("E11:F11").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Sheets("PODUZEĆE_PLAĆA").Select
        Range("G6:H6").Select
        ActiveSheet.Paste
        Columns("B:H").Select
        Columns("B:H").EntireColumn.AutoFit
        Range("A2").Select
        Sheets("Neto plaća").Select
        ActiveSheet.ListObjects("Tablica_Upit_iz_MS_Access_Database_14").Range. _
            AutoFilter Field:=207
        ActiveSheet.ListObjects("Tablica_Upit_iz_MS_Access_Database_14").Range. _
            AutoFilter Field:=204
        Sheets("PODUZEĆE_PLAĆA").Select
        Range("B5").Select
        ActiveCell.FormulaR1C1 = "=COUNTIF((R[2]C:R[100]C),R[-4]C[-1])"
        Range("E5").Select
        ActiveCell.FormulaR1C1 = "=SUM(R[2]C:R[100]C)"
        Range("E5").Select
        Selection.AutoFill Destination:=Range("E5:F5"), Type:=xlFillDefault
        Range("E5:F5").Select
        Range("B6:H6").Select
        Range(Selection, Selection.End(xlDown)).Select
        ActiveWorkbook.Worksheets("PODUZEĆE_PLAĆA").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("PODUZEĆE_PLAĆA").Sort.SortFields.Add Key:=Range( _
            "C7:C129"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With ActiveWorkbook.Worksheets("PODUZEĆE_PLAĆA").Sort
            .SetRange Range("B6:H129")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range("B7:H7").Select
        Range(Selection, Selection.End(xlDown)).Select
        With Selection.Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Sheets("PLAĆA_SPISAK").Select
        ActiveSheet.Range("$C$10:$G$60").AutoFilter Field:=1, Criteria1:="<>"
        Sheets("PODUZEĆE_PLAĆA").Select
        Range("B5").Select
        Sheets("2001").Select
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Macro-recorder code is slow because it mimics a user clicking and selecting cells. You must rewrite it using `Range` variables instead and remove all `Range.Select` instructions. Most copy/paste operations don't need to involve the clipboard, either; if you only need the values you can take them from one range to another as a single operation. — Mathieu Guindon, Oct 09 '22 at 12:49
You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/q/10714251/4996248). — John Coleman, Oct 09 '22 at 12:51
Can you show me at least one copy of it on this example of mine? — Filip Mišić, Oct 09 '22 at 12:59
`Sheets("Neto plaća").Select Range("E11:F11").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy` It has 3-times a `Select`, which is not needed when you read the linked question/answer. — Luuk, Oct 09 '22 at 13:00
Yes but then that's all implicitly late-bound and will be very prone to error 438. Declare and use variables instead, and have `Option Explicit` at the top of the module. `Dim sourceSheet As Worksheet` / `Set sourceSheet = Worksheets("Neto plaća")` / `Dim someRange As Range` / `Set someRange = sourceSheet.Range("E11:F11")` / then you'll have intellisense and parameter completion when you want to do anything with `someRange`. — Mathieu Guindon, Oct 09 '22 at 13:30

score 2 · Answer 1 · answered Oct 09 '22 at 15:12

Getting Rid of Active and Select (Translating Macro-Recorder Code)

Not tested.
There is still much room for improvement but it should illustrate what it could look like.
It compiles but that doesn't mean it's gonna work. Give it a try and share some feedback.

Issues

If there is no match in the table, the code will fail.
If the data isn't 'nice' and has empty rows, the xlDown lines will fail.
Maybe it would be preferable to write the formulas in A1 style.

The Code

Option Explicit

Sub Obracun_place_OLP_NEAKTIVNO()
    
    Application.ScreenUpdating = False
    
    'Refresh_neto_TM '?
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Neto plaća")
    Dim stbl As ListObject
    Set stbl = sws.ListObjects("Tablica_Upit_iz_MS_Access_Database_14")
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets("PODUZEĆE_PLAĆA")
    
    ' Clear the (old) destination data range (headers are in row 6).
    With dws.Range("B7:H7")
        .Range(.Cells, .End(xlDown)).ClearContents
    End With
    
    ' Filter the source table.
    With stbl
        ' Clear possible existing filters.
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        Else
            .ShowAutoFilter = True
        End If
        ' Filter.
        .Range.AutoFilter Field:=204, Criteria1:=CStr(sws.Range("A2").Value)
        .Range.AutoFilter Field:=207, Criteria1:="<>"
    End With
    
    ' Copy the data from the source to the destination worksheet.
    With sws
        With .Range("GV11:GZ11")
            .Range(.Cells, .End(xlDown)).Copy dws.Range("B6:F6")
        End With
        With .Range("E11:F11")
            .Range(.Cells, .End(xlDown)).Copy dws.Range("G6:H6")
        End With
        sws.Columns("B:H").EntireColumn.AutoFit
        'Application.Goto sws.Range("A2") ' reset to initial selection
    End With
    
    ' Clear the table filters.
    stbl.AutoFilter.ShowAllData
    
    With dws
        
        ' Reference the (new) destination range ('drg').
        Dim drg As Range
        With dws.Range("B6:H6")
            Set drg = .Range(.Cells, .End(xlDown))
        End With
        
        ' Write formulas.
        Dim lfRow As Long: lfRow = drg.Rows.Count ' last formula row
        .Range("B5").FormulaR1C1 _
            = "=COUNTIF((R[2]C:R[" & lfRow & "]C),R[-4]C[-1])"
        .Range("E5:F5").FormulaR1C1 = "=SUM(R[2]C:R[" & lfRow & "]C)"
        
        ' Sort by the 2nd column ('C').
        With .Sort
            .SortFields.Clear
            .SortFields.Add _
                Key:=drg.Columns(2), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            .SetRange drg
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    
        ' Apply formatting.
        With drg.Resize(drg.Rows.Count - 1).Offset(1) ' 'drg' without headers
            With .Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End With
    
        'Application.Goto .Range("B5") ' reset to initial selection
    
    End With
    
    ' These are irrelevant, the second one probably not necessary!?
    wb.Worksheets("PLAĆA_SPISAK").Range("C10:G60").AutoFilter 1, "<>"
    'Application.Goto wb.Worksheets("2001").Range("A1")
    
    Application.ScreenUpdating = True

End Sub

FROM this code of yours, I tried to figure out how to include other code, but I keep getting an error with .Range.AutoFilter Field:=1, Criteria1:=(sws.Range("A2").Value) — Filip Mišić, Oct 10 '22 at 14:02

How can I speed up this loop

1 Answers1

Getting Rid of Active and Select (Translating Macro-Recorder Code)