Image كود لنسخ الأصناف إلى صفحاتها

السلام عليكم و رحمة الله و بركاته

فكرة الكود تقوم على التالي:
1.     يوجد لدينا حركات أصناف في الصفحة الرئيسية و هي صفحة الحركات و اسمهاTotal و اسماء الاصناف موجودة في العمود A
2.     و يوجد عدد من الاصناف من ضمنها صنف اسمهOrange و له أيضاً صفحة اسمها Orange .
3.     و صنف آخر اسمهApple  و له أيضاً صفحة بنفس الإسم
4.     و نريد كود يقوم بعملcut  لاسم الصنف و من ثم Paste  في الصفحة المرتبطة بإسمه .
و لعمل ذلك قدمت الكود التالي:

 Sub Excel4Us()

 Dim c As Range, LR As Integer, Rng As Range
 Application.EnableEvents = False
 LR = Sheets("Total").Range("a" & Rows.Count).End(xlUp).Row
 Set Rng = Sheets("Total").Range("a2:a" & LR)
 For Each c In Rng
     Select Case c.Value
         Case Is = "Apple"
            c.EntireRow.Cut Sheets("apple").Range("a" & Sheets("apple").Range("a" & Rows.Count).End(xlUp).Row + 1)
         Case Is = "Orange"
            c.EntireRow.Cut Sheets("Orange").Range("a" & Sheets("Orange").Range("a" & Rows.Count).End(xlUp).Row + 1)
     End Select
 Next c
 Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 Application.EnableEvents = True
 End Sub

__________________

و لكن عند تطبيقه

سنلاحظ البطئ في حركات القص و اللصق

و لذلك قمت بعمل كود اخر رديف له

و هو سريع بإستخدام خاصية الفلترة

و كان هذا هو الكود :

 Sub Excel4Us()
 Dim c As Range, LR As Integer, Rng As Range, Product()
 Application.EnableEvents = False
 LR = Sheets("Total").Range("a" & Rows.Count).End(xlUp).Row
 Set Rng = Sheets("Total").Range("a2:d" & LR)
 Product = Array("Apple", "Orange")
 Range("A1:D1").AutoFilter
 With Rng
     For i = LBound(Product) To UBound(Product)