Benzersizleri süz yapıştır makrosu hk

[OZCANLOK]

Aşağıdaki kodu nasıl kısaltabiliriz
makro çok uzu süre çalışyor Teşekkürler

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
On Error Resume Next
Set s1 = Sheets("Pat")
Set s2 = Sheets("Bmc takip")

Set Alan1 = s1.Range("b1:e403")
Set alan2 = s1.Range("k1:k2")
Set alan3 = s1.Range("f1:ı403")
Set alan4 = s1.Range("H2:I41")
Set alan5 = s2.Range("b23:c62")
s1.Visible = xlSheetVisible
alan3.ClearContents
alan5.ClearContents
Alan1.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=alan2, CopyToRange:=alan3, Unique:=True
Application.ScreenUpdating = False
Range("F2:I403").Select
Selection.Sort Key1:=Range("F2"), Order1:=xlDescending, Key2:=Range("G2") _
, Order2:=xlAscending, Key3:=Range("I2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Application.CutCopyMode = False

s1.Select
alan4.Select
Selection.Copy
s2.Select
alan5.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
s1.Visible = xlSheetVeryHidden
'Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = True
End Sub

 

[Ferhat Pazarçevirdi]

 'Application.Calculation = xlCalculationManual
'Application.Calculation = xlCalculationAutomatic

Bu satırların başındaki tırnakları kaldırın ve deneyin. Anlaşılan baya yüklü formuller var sayfanızda