اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

السلام عليكم

من فضلكم

في الملف المرفق 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

  • Like 3
  • Thanks 2
رابط هذا التعليق
شارك

السلام عليكم

الأخ الكريم:

سليم حاصبيا

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

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

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

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

رابط هذا التعليق
شارك

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

هكذا مثلا

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

 

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

 

 

  • Like 1
رابط هذا التعليق
شارك

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

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

  • Like 1
رابط هذا التعليق
شارك

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

الملف مرفق

 

Range.png

H_2611 -2.xls

  • Thanks 2
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information