طلب كود ترحيل النتائج إلى أوراق الأقسام

[hicham2610]

السلام عليكم

من فضلكم

في الملف المرفق 5 أوراق

في الورقة g بها نتائج المتعلمين مجتمعة (الأقسام الأربعة)

الورقة 1 نتائج القسم 1  فارغة

الورقة 2 نتائج القسم 2  فارغة

الورقة 3 نتائج القسم 3 فارغة

الورقة 4 نتائج القسم 4 فارغة

كيف يمكن برمجة زر الورقة g يحيث يتم ترحيل النتائج إلى كل ورقة (1و2و3و4)بعد التأكد من مطابقة العناصر التالية: رقم التلميذ والاسم وتاريخ الازدياد تفاديا للخطأ 

وجزاكم الله خيرا

6.xlsx

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

جرب هذا الكود

Option Explicit
Sub My_Ad_filter()
Dim Rg As Range
Dim Cret_rg As Range
Dim arr, itm
Application.ScreenUpdating = False
arr = Array(1, 2, 3, 4)
Set Rg = Sheets("g").Range("A14").CurrentRegion
For Each itm In arr
  With Sheets(itm & "")
    .Range("A14").CurrentRegion.ClearContents
    .Range("MM1") = "القسم"
    .Range("MM2") = itm
     Set Cret_rg = .Range("MM1:MM2")
     Rg.AdvancedFilter 2, Cret_rg, .Range("A14")
     Cret_rg.ClearContents
  End With
Next
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

H_2610.xlsm

[hicham2610]

السلام عليكم

الأخ الكريم:

سليم حاصبيا

جزاك الله خيرا وأحسن إليك

لكن هناك تغيير في جداول الأوراق 1-2-3 و4

ممكن الإبقاء على الأوراق كما هي في الملف الأصلي وإجراء المطلوب؟

جزاك الله خيرا وأحسن إليك

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

تم التغيير في تصميم الأوراق لانها كانت تحتوى على خلايا مدمجة تعيق عمل الكود

[seddiki_adz]

مشكور على هدا العمل العظيم

لكن عندي تساؤل لوكان الصفحات ليست ارقم بل هي اسماء : مكان 1 و 2 و 3 و 4 تكون مثلا محمد ، سمير ، سليم ، بن علي 

كيف نغير الكود؟

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

تستدبل قيم الــ  Array  بالأسماء  (ما ليس رقماً داخل اقواس " "    اما الأرقام بدون اقواس)

هكذا مثلا

arr = Array("سعيد", "أكرم", 3, 4, "Amine", "سليم")

 

 

[seddiki_adz]

بارك الله فيك اخي

بعد تطبيقة على الملف لاحظ يوجد خطا

تم تعديل أغسطس 9, 2020 بواسطه seddiki_adz

[abouelhassan]

شكر تقدير واحترام من اخيك

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

اذا كانت العناصر في الـــ Array نصوصاً لا لزوم للأقواس في السطر حيث الخطأ (الأ صفر)   (حتى وان وضعتها لا مشكلة)

كما عليك وضع اسماء الصحفات الـــ Array   وليس اي اسماء تخطر على بالك

اما مكان الــ  Itm  في يقية اسطر الكود (بعد سطر الخطأ) تضع الشيء الذي تريد ان تفلتر على اساسه
بين قوسين اذا كان نصاً

 

 

[عبدالفتاح في بي اكسيل]

اخي  الكريم  كود  الاستاد  سليم  يعمل  لو  ركزت  على  الكود  لعرفت  الخلل اين 

في  سطر  المصفوفة  اسماء  الشيتات  غير  مفهومة  اكتبها  يدويا  في  سطر  الكود  لا بد  انك  قمت  بنسخ  ولصق  وهذا  يحدث  في  حالة  اللغة  العربية فقط  

[seddiki_adz]

لاحظ احي المادة : عربية ، فرنسية، فيزياء ، علوم

H_2610 -2.xls

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

1- من ايت يأتي لك الاكسل بالورقة رياضيات وهي ليست موجودة ضمن الأوراق

2-يظهر انك تستعمل اصدار قديم من اكسل ليس فيه العامود MM

3- في هذه الحالة يمكن الاستعانة بأي عامود   غير  MM   مثلاُ  Z

لاحظ الصورة

فيصبح الكود بهذا الشكل

Option Explicit
Sub My_Ad_filter()
Dim Rg As Range
Dim Cret_rg As Range
Dim arr, itm
Application.ScreenUpdating = False

arr = Array("عربية", "فيزياء", "فرنسية")


Set Rg = Sheets("g").Range("A14").CurrentRegion
For Each itm In arr
  With Sheets(itm)
    .Range("A14").CurrentRegion.ClearContents
    .Range("Z1") = "المادة"
    .Range("Z2") = itm
     Set Cret_rg = .Range("Z1:Z2")
     Rg.AdvancedFilter 2, Cret_rg, .Range("A14")
     Cret_rg.ClearContents
  End With
Next
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

H_2611 -2.xls

[seddiki_adz]

نعم استعمل 2007 

شكرا جزيلا و بورك فيك

جزاك الله خيرا