هل يمكن اختصار الكود التالي ليصبح اخف

[gamalin]

الاخوة الافاضل الكود التالي يعمل جيدا ولكن مع تزايد البيانات يصبح بطئ جدا فهل يمكن اجراء اي تحسين عليه ليصبح اخف واسرع 
مرفق ملف 
في شيت itemout 
الزر new يقوم بالتشغيل 
ليتم ترحيل البيانات الى عدد اربعة شيتات اخرى 

Sub sale_m()
On Error Resume Next
Application.ScreenUpdating = False
 Sheets("perform").Unprotect Password:="m"
 Sheets("accmove").Unprotect Password:="m"
 Sheets("AccMove D").Unprotect Password:="m"
 Sheets("itemmove").Unprotect Password:="m"
 Sheets("itemout").Unprotect Password:="m"
           Sheets("Accmove").Rows("3:3").AutoFilter
           Sheets("AccMove D").Rows("4:4").AutoFilter
           Sheets("perform").Rows("4:4").AutoFilter
           Sheets("itemmove").Rows("4:4").AutoFilter
           Sheets("itemout").Rows("7:7").AutoFilter
Sheets("itemout").Select
    If Cells(2, 2) = "" Or Cells(5, 2) = "" Or Cells(8, 2) = "" Or Cells(2, 5) = "" Then
          MsgBox " Çßãá ÇáÈíÇäÇÊ , äæÚ ÇáÍÑßÉ , ßæÏ ÇáÚãíá , ßæÏ ÇáÕäÝ , ÇáÇÐä ÇáíÏæí "
            Range("b8").Select
           Sheets("Accmove").Rows("3:3").AutoFilter
           Sheets("AccMove D").Rows("4:4").AutoFilter
           Sheets("perform").Rows("4:4").AutoFilter
           Sheets("itemmove").Rows("4:4").AutoFilter
           Sheets("itemout").Rows("7:7").AutoFilter

Sheets("perform").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("itemmove").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("accmove").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("AccMove D").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("itemout").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("itemout").Select
       Exit Sub
    Else
  '  If Cells(2, 2) = "" Then MsgBox "ÇÎÊÑ äæÚ ÇáÍÑßÉ = ", 64, vbExclamation
  '  If Cells(5, 2) = "" Then MsgBox "ÇÏÎá ßæÏ ÇáãæÑÏ = ", 64, vbExclamation
  '  If Cells(8, 2) = "" Then MsgBox "ÇÏÎá ßæÏ ÇáÕäÝ = ", 64, vbExclamation
  '  If Cells(2, 5) = "" Then MsgBox "ÇÏÎá ÇáÇÐä ÇáíÏæí = ", 64, vbExclamation
For a = 8 To [b1000].End(xlUp).Row
         With Sheets("perform").[a50000].End(xlUp)
              .Offset(1, 0).FormulaR1C1 = "=if((r[-1]c)<>""ã"",(r[-1]c)+1,1)"
              .Offset(1, 1) = Cells(3, 2)
              .Offset(1, 2) = Cells(4, 2)
              .Offset(1, 3) = Cells(5, 2)
              .Offset(1, 4) = Cells(6, 2)
              .Offset(1, 5) = Cells(2, 5)
              .Offset(1, 6) = Cells(a, 2)
              .Offset(1, 7) = Cells(a, 3)
              .Offset(1, 😎 = Cells(a, 4)
              .Offset(1, 9) = Cells(a, 5)
         If Sheets("itemout").Cells(2, 2).Value <> "ãÑÏæÏÇÊ ãÈíÚÇÊ" Then
              .Offset(1, 10) = Cells(a, 6) * -1
           Else
              .Offset(1, 10) = Cells(a, 6)
        End If
              .Offset(1, 11) = Cells(a, 7)
              .Offset(1, 13).FormulaR1C1 = "=(RC[-3]*rc[-2])"
              .Offset(1, 15) = "no"
              .Offset(1, 21) = Cells(2, 2)
              .Offset(1, 25).FormulaR1C1 = "=IF(RC[-13]>0,RC[-13]*-1,RC[-15])"
              .Offset(1, 26).FormulaR1C1 = "=IF(RC[-14]>0,(RC[-16]+RC[-14])/RC[-16],0)"
              .Offset(1, 27).FormulaR1C1 = "=MONTH(RC[-25])"
End With
Next a
For a = 8 To [b1000].End(xlUp).Row
         With Sheets("AccMove D").[a50000].End(xlUp)
              .Offset(1, 0).FormulaR1C1 = "=row()-4"
              .Offset(1, 1) = Cells(3, 2)
              .Offset(1, 2) = Cells(4, 2)
              .Offset(1, 3) = Cells(5, 2)
              .Offset(1, 4) = Cells(6, 2)
              .Offset(1, 5) = Cells(2, 5)
              .Offset(1, 6) = Cells(a, 2)
              .Offset(1, 7) = Cells(a, 3)
              .Offset(1, 😎 = Cells(a, 4)
              .Offset(1, 9) = Cells(a, 5)
         If Sheets("itemout").Cells(2, 2).Value = "ãÑÏæÏÇÊ ãÈíÚÇÊ" Then
              .Offset(1, 10) = Cells(a, 6)
           Else
              .Offset(1, 10) = Cells(a, 6)
        End If
              .Offset(1, 11) = Cells(a, 7)
              .Offset(1, 13).FormulaR1C1 = "=(RC[-3]*rc[-2])"
              .Offset(1, 15) = "no"
              .Offset(1, 21) = Cells(2, 2)
              .Offset(1, 22).FormulaR1C1 = _
        "=IF(RC[-21]<>R[-1]C[-21],SUMIFS(C[-9],C[-21],RC[-21],C[-1],RC[-1]),0)"
         If Sheets("itemout").Cells(2, 2).Value = "ãÑÏæÏÇÊ ãÈíÚÇÊ" Then
              .Offset(1, 24).FormulaR1C1 = _
        "=IF(OR(RC[-3]<>R[-1]C[-3],RC[-23]<>R[-1]C[-23]),SUMIFS(C[-11],C[-23],RC[-23],C[-3],RC[-3]),0)"

           Else
              .Offset(1, 23).FormulaR1C1 = _
        "=IF(OR(RC[-2]<>R[-1]C[-2],RC[-22]<>R[-1]C[-22]),SUMIFS(C[-10],C[-22],RC[-22],C[-2],RC[-2]),0)"
        End If
              .Offset(1, 25).FormulaR1C1 = _
        "=SUMIFS(R4C[-2]:RC[-2],R4C[-22]:RC[-22],RC[-22])-SUMIFS(R4C[-1]:RC[-1],R4C[-22]:RC[-22],RC[-22])"
           '   .Offset(1, 26).FormulaR1C1 = "=IF(RC[-14]>0,(RC[-16]+RC[-14])/RC[-16],0)"
           '   .Offset(1, 27).FormulaR1C1 = "=MONTH(RC[-25])"
           '   .Offset(1, 28).FormulaR1C1 = "=year(RC[-26])"
End With
Next a
For a = 8 To [b1000].End(xlUp).Row
         With Sheets("itemmove").[a50000].End(xlUp)
              .Offset(1, 0).FormulaR1C1 = "=if((r[-1]c)<>""ã"",(r[-1]c)+1,1)"
              .Offset(1, 1) = Cells(a, 2)
              .Offset(1, 2) = Cells(a, 3)
              .Offset(1, 3) = Cells(a, 4)
              .Offset(1, 4) = Cells(a, 5)
              .Offset(1, 5) = Cells(2, 2)
              .Offset(1, 6) = Cells(3, 2)
              .Offset(1, 7) = Cells(2, 5)
         If Sheets("itemout").Cells(2, 2).Value <> "ãÑÏæÏÇÊ ãÈíÚÇÊ" Then
              .Offset(1, 9) = Cells(a, 11)
            Else
              .Offset(1, 😎 = Cells(a, 11)
         End If
              .Offset(1, 10).FormulaR1C1 = _
                            "=SUMIFS(R5C[-2]:RC[-2],R5C[-9]:RC[-9],RC[-9])-SUMIFS(R5C[-1]:RC[-1],R5C[-9]:RC[-9],RC[-9])"
              .Offset(1, 11) = Cells(5, 2)
              .Offset(1, 12) = Cells(a, 13)
              .Offset(1, 14) = Cells(4, 2)
End With

Next a
For a = 8 To [b1000].End(xlUp).Row

         With Sheets("accmove").[a50000].End(xlUp)
              .Offset(1, 0).FormulaR1C1 = "=row()-3"
              .Offset(1, 1) = Cells(5, 2)
              .Offset(1, 2) = Cells(6, 2)
              .Offset(1, 4) = Cells(3, 2)
              .Offset(1, 5) = Cells(2, 5)
              .Offset(1, 6) = Cells(4, 2)
         If Sheets("itemout").Cells(2, 2).Value <> "ãÑÏæÏÇÊ ãÈíÚÇÊ" Then
              .Offset(1, 7) = Cells(36, 😎
             Else
              .Offset(1, 😎 = Cells(36, 😎
         End If
              .Offset(1, 9).FormulaR1C1 = _
                           "=SUMIFS(R4C[-2]:RC[-2],R4C[-8]:RC[-8],RC[-8])-SUMIFS(R4C[-1]:RC[-1],R4C[-8]:RC[-8],RC[-8])"
              .Offset(1, 10) = Cells(a, 6)
              .Offset(1, 11) = Cells(34, 😎
              .Offset(1, 13) = Cells(35, 😎
            '  .Offset(1, 14).FormulaR1C1 = "=VLOOKUP(RC[-13],acc!C[-13]:C[-3],8,FALSE)"
              .Offset(1, 15) = Cells(2, 2)
              .Offset(1, 18) = Cells(5, 3)
              .Offset(1, 19).FormulaR1C1 = "=MONTH(RC[-13])"
End With
Next a
'For a = 8 To [b1000].End(xlUp).Row
     Sheets("itemout").Select
    ActiveSheet.Range("$A$7:$H$40").AutoFilter Field:=2, Criteria1:="<>"
    Range("A1:H36").Select
'    Selection.PrintOut Copies:=2, Collate:=True

'Application.Run "sale_clr"
End If
           Sheets("Accmove").Rows("3:3").AutoFilter
           Sheets("perform").Rows("4:4").AutoFilter
           Sheets("itemmove").Rows("4:4").AutoFilter
           Sheets("itemout").Rows("7:7").AutoFilter

Sheets("perform").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("itemmove").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("accmove").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("AccMove D").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
Sheets("itemout").Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True

End Sub

officena test.xlsm