How can I speed up this loop-CodePudding

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

CodePudding user response：

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

CodePudding user response：

I got this code

Sub Obracun_place_NOVI_FILIP()

    Application.ScreenUpdating = False
    
    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 Range
    Set stbl = sws.Range("$CJ$11:$CO$4112")
    
    ' 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:=1, Criteria1:=(sws.Range("A2").Value)
        .Range.AutoFilter Field:=4, Criteria1:="<>"
     End With
    
    
    
    
      ' Copy the data from the source to the destination worksheet.
    With sws
        With .Range("$CJ$11:$CO$4112")
        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("B6:H129")
        End With
    
     '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
    End With

    Placa_Spisak_Filter
    
    Osvjezi_preb
    OSVJEZI_BROJ_OPCINA
    'Sheets("Neto plaća").ShowAllData

    
'Lista_doprinosa
Sheets("2001").Select
Application.ScreenUpdating = True
'Save_Lista_AsPDF

End Sub

FROM this code:

Sub Obracun_place_NOVI_BK()

    Application.ScreenUpdating = False
    
    
    'Application.Calculation = xlManual
    'Call Refresh_neto_TM
    
    Sheets("PODUZEĆE_PLAĆA").Select
    Range("B7:H129").ClearContents 'Select
    'Selection.ClearContents

    Sheets("Neto plaća").Select
    ActiveSheet.Range("$CJ$11:$CO$4112").AutoFilter Field:=1, Criteria1:=Range("A2")
    ActiveSheet.Range("$CJ$11:$CO$4112").AutoFilter Field:=4, Criteria1:="<>"
    Range("CI11:CO11").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("PODUZEĆE_PLAĆA").Select
    Range("B6").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    'ActiveSheet.Paste
   ' Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    
    
    '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:C127"), 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
    
    Placa_Spisak_Filter
    
    'Sheets("MLJEKARA_SPISAK_UCB").Select
    'ActiveSheet.Range("$C$10:$G$90").AutoFilter Field:=1, Criteria1:="<>"
    'Sheets("2001").Select
    'If Range("A71") = True Then
    'Call MINULI
    'End If
    Call Osvjezi_preb
    Call OSVJEZI_BROJ_OPCINA
    Sheets("Neto plaća").ShowAllData
    'Sheets("Neto plaća").Select
    'ActiveSheet.Range("$IV$11:$JB$4112").AutoFilter Field:=1
    'ActiveSheet.Range("$IV$11:$JB$4112").AutoFilter Field:=4
    
'Lista_doprinosa
Sheets("2001").Select
Application.ScreenUpdating = True
'Save_Lista_AsPDF
End Sub