اريد مساعدة كود تصفية المنح المدرسية و ترحيل البيانات

[ابوذر]

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

اريد مساعد عجلة منكم جزاكم الله كل خير 

رغم تحميل مختف الاكود و التعديل عليها لم انجح في تعديل 

اريد ان يعمل الملف على النحو التالي:

نقل جميع بيانات التلاميذ الناجحين الى شيت جديد باسم ممنوح و نقل جميع بيانات الراسبين الى شيت تجميد

وشكر

 

جدول تصفية المنح.rar

تم تعديل يوليو 19, 2016 بواسطه aboudher

[سليم حاصبيا]

14 دقائق مضت, aboudher said:

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

اريد مساعد عجلة منكم جزاكم الله كل خير 

رغم تحميل مختف الاكود و التعديل عليها لم انجح في تعديل 

اريد ان يعمل الملف على النحو التالي:

نقل جميع بيانات التلاميذ الناجحين الى شيت جديد باسم ممنوح و نقل جميع بيانات الراسبين الى شيت تجميد

وشكر

جدول تصفية المنح.rar

اين هي البيانات 

لا ارى الا جداول فارغة

اضف بعض البيانات وليس كلها 

فمن اين نعرف مثلاً ما هي علامة النجاح والرسوب و ما هو قرار المجلس الخ....

[ابوذر]

50 دقائق مضت, سليم حاصبيا said:

اخي سليم اشكرك على الرد السريع .

النتيجة ناجح او راسب و قرار المجلس يتم كتابته يدويا

جدول تصفية المنح.rar

[أبوعيد]

أولا : فضلا لا أمرا

الرجاء تغيبر اسم ظهورك إلى اللغة العربية بدلا من الأنجليزية

كما هو المعمول به في هذا المنتدى

ثانيا :

تفضل اضغط زر ترحيل وسيقوم بالمهمة

جرب المرفق

جدول تصفية المنح1.rar

تم تعديل يوليو 19, 2016 بواسطه أبوعيد

[سليم حاصبيا]

ربما يكون هذا الكود اسرع 

Sub Salim_Tarhil()
Dim Source_Sheet, Target_Sheet1, Target_Sheet2 As Worksheet
Set Source_Sheet = Sheets("بيانات الممنوحين")
Set Target_Sheet1 = Sheets("ممنوح"): Set Target_Sheet2 = Sheets("تجميد")
 Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
           With Sheets(i)
              .AutoFilterMode = False
               If .FilterMode = True Then .ShowAllData
            End With
     Next
Target_Sheet1.Range("a10:m1000").ClearContents
Target_Sheet2.Range("a10:m1000").ClearContents
   

   Source_Sheet.Range("$A$8:$M$1000").AutoFilter Field:=12, Criteria1:="ناجح"
   Source_Sheet.Range("$A$9:$M$1000").SpecialCells(12).Copy Destination:=Target_Sheet1.Range("a10")


    Source_Sheet.Range("$A$8:$M$1000").AutoFilter Field:=12, Criteria1:="راسب"
    Source_Sheet.Range("$A$9:$M$1000").SpecialCells(12).Copy Destination:=Target_Sheet2.Range("a10")
'
Source_Sheet.ShowAllData
Application.ScreenUpdating = True
End Sub

 

تم تعديل يوليو 19, 2016 بواسطه سليم حاصبيا

[ابوذر]

شكرا والف شكررررررررررررررررررررررررررررررررررررررر على المجهود