How can I speed up this loop - vba

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

Answer 1

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