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

فكرة الكود تقوم على التالي:

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)