Macro tweede blad (groep) traag na onderstaande code

[skools]

Hopelijk hebben jullie een goede raad, na het draaien van onderstaande code wordt het excel sheet groep traag.



Sub SetGroupSheet()
'DisplayProgressInStatusbar
Application.DisplayStatusBar = True

' Enter your message for the statusbar:
Application.StatusBar = "Sheet groep wordt aangemaakt met behulp van Input filters"

Application.ScreenUpdating = False


'Bepalen filter aan de hand van managers blad input
Dim LOB As String
Dim LOBPC As String
Dim LOBMC As String
Dim LOBCO As String
LOB = Range("LOB").Value
LOBPC = Range("LOBPC").Value
LOBMC = Range("LOBMC").Value
LOBCO = Range("LOBCO").Value

'Schoonmaken sheet Groep
Sheets("Groep").Select
Range("A1 ").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Clear
Range("A1").Select

'tabelopmaak verwijderen uit sheet
Sheets("Download").Select
Application.GoTo Reference:="Tabel_owssvr"
ActiveSheet.ListObjects("Tabel_owssvr").Unlist
ActiveWindow.SmallScroll Down:=-21


'Vervangen oude PC/MC LOB voor CO (VLOOKUP Lijst en Berekening manager)
Sheets("Download").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Selection.NumberFormat = "General"
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[3],Lmanlob,2,0)"
Selection.AutoFill Destination:=Range("a2:a1000")

Columns("G:G").Select
Selection.Copy
Columns("F:F").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

With Application
.Calculation = xlCalculationAutomatic
End With

With Application
.Calculation = xlCalculationManual
End With


'Filter plaatsen op download (LOB = FP, LOBCO = CO)
Sheets("Download").Select
Range("a1").AutoFilter Field:=1, _
Criteria1:=Array(LOB, LOBCO), _
Operator:=xlFilterValues
'Range("a1").AutoFilter Field:=6, _
'Operator:=xlFilterValues, Criteria2:=Array(0, "12/31/2009", 0, "2/28/2012", 0, _
"12/31/2011", 0, "12/31/2010")

Sheets("Download").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy Destination:=Sheets("Groep").Range("a1")

'Kopieren naar sheet groep
' Sheets("Groep").Select
' ActiveSheet.Paste

'unfilter on first sheet
Sheets("Download").Select
Range("a1").AutoFilter Field:=3
Sheets("Input").Select

'Clear Clipboard
Application.CutCopyMode = False

'resetten niet veranderen van screen
Application.ScreenUpdating = True

' Status bar resetten :
Application.StatusBar = False

MsgBox "De sheet Groep bevat alle xx (volledige en onvolledige)!"


End Sub