كود كان يعمل و أصبح لا يعمل بعد تغيير بعض البيانات الرجاء تصحيحه

[يوسف عطا]

هذا الكود كان يعمل جيداً

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect
Set MyRng1 = [F1:AK2]
Set MyRng2 = [D10:AJ2000]
If MsgBox("هل تريد الترحيل حسب الشروط", vbYesNo, "تنبيه") = vbYes Then
Sheets("1").Range("C10:AH2000").AdvancedFilter xlFilterCopy, MyRng1, MyRng2
MsgBox "تم الترحيل بنجاح ", vbOKOnly, "تنبيه"
End If
Set MyRng1 = Nothing
Set MyRng2 = Nothing
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

وبعد تعديل بعض البيانات اصبح لا يعمل

الرجاء المساعدة فى تحديد سبب الخطأ و العمل على تصحيحه

علماً بأن العلامة الصفراء تظهر على السطر التالى

Sheets("1").Range("C10:AH2000").AdvancedFilter xlFilterCopy, MyRng1, MyRng2

 MyRng1, MyRng2ولا أعرف ما المقصود ب 

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

لاكتشاف الخطأ يجب تشغيل الكود على الملف مباشرة

لذا قم بتحميل الملف او جزء منه اذا كان كبيراً

[يوسف عطا]

حالا يا استاذنا سيتم التحميل إن شاء الله

الكود فى شيت كشوف التوقيعات

برنامج إعداد لجنة ثانوية عامة 1.rar

تم تعديل يونيو 1, 2019 بواسطه يوسف عطا

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

لم افهم شيء من ملفك

النطاق A1:Ak2  Activesheet يحتوي عل خلايا فارغة

عندك مشكلة في الخلايا المدمجة (علة العلل للعمل بالاكواد)

غير ذلك تريد تنفيذ ماكرو على  Activesheet في هذه الحالة الماكرو  سوف يعمل على الشيت النشطة حتى وان كانت غير المطلوبة

لذا دائماً قم بتحديد الشيت المعني بالأمر

 

[يوسف عطا]

هبعت لحضرتك نشخة شغالة من الشيت قبل التعديل و للتوضيح
الشيت بيتكون من عدة صفحات

الأولى صفحة البيانات الاساسية للطلبة وفيها بنعمل نسخة من الكشوف اللى جاية من الكنترول و بنضيف بعض المعادلات بتساعدنا فى شغلنا بعد كدة
التانية فيها دليل اللجان بنحدد فيها كل لجنة فيها كام طالب و أرقام جلوسهم و و إحصائيات المواد

التالتة فيها إحصائيات عامة لكل لجان اللجنة الفرعية و إحصاء عام

الرابعة فيها كشف التوقيعات الأوتوماتيكية وده اللى بيتنفذ فيه الكود اللى اتلخبط لما عملت تعديل على المواد المشتركة اللى بتتغير من سنة لسنة

الخامسة دى فيها مشكلة كبيرة ومش عارف أحلها و محتاجة خبير معادلات كدة زى حضرتك وهى خاصة بدليل التظريف المفروض كل إمتحان كراسات إجابته بتتظرف خمسينات خمسينات و آخر مظروف فقط هو اللى بيكون اقل من 50 فالمفروض الدليل ده بيطلعلى من واقع البيانات فى الملف عدد المظاريف لكل امتحان و بداية و نهاية كل مظروف من حيث أرقام الجلوس وغالبا بتكون مختلفة فى كل امتحان عن التانى و بيحددلى عدد الكراسات فى المظروف الأخير اللى بتكون مختلفة فى كل مادة عن التانية

النسخة الشغالة مرفقة المفروض فى صفحة التوقيعات بنحدد رقم اللجنة فوق و أسماء مواد الإمتحان فالكود بيجيب اسماء الطلاب فى كل لجنة وبعض بياناتهم

اعداد لجنة ث ع شغال قديم.rar

[يوسف عطا]

للرفع

رفع الله قدركم

[محمد طاهر عرفه]

الملف الاخير به مشكلة في الضغط

يمكتك رفع ملف الاكسيل مباشرة دون ضغط

[محمد طاهر عرفه]

دون الدخول فى تفاصيل الملف حيث لم استطع تحميله ، جاولت تعديل الكود ببحسب ما فهمت ، انه يقوم بفلترة و بترحيل من مجال 1 الي مجال 2 بعد فك الحماية

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

Private Sub Worksheet_Change(ByVal Target As Range)


ActiveSheet.Unprotect

Dim Range0, Range1, Range2 As Range
Set Range0 = Range("A1:gg20000")
Set Range1 = Range("A1:B2")
Set Range2 = Range("C1:D2")

    If MsgBox("هل تريد الترحيل حسب الشروط", vbYesNo, "تنبيه") = vbYes Then
        Range0.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range1, CopyToRange:=Range2
        MsgBox "تم الترحيل بنجاح  ", vbOKOnly, "تنبيه"
    End If

Set Range0 = Nothing
Set Range1 = Nothing
Set Range2 = Nothing


ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

 

 

[يوسف عطا]

الف شكر يا أستاذنا الكبير محمد بك حفظه الله

بنسخ كود سيادتكم  ظلت المشكلة كما هى لكن بالبحث فى الكود و عمله إكتشفت أن التعديل الذى قمت به و تسبب فى وقف الكود كان ينبغى أن أكرر التعديل فى رؤوس أعمدة الهدف كما غيرته فى رؤوس أعمدة المصدر
حيث أن الكود يقوم بعمل فلترة للبيانات وبتغيير رؤوس الأعمدة فى المصدر دون الهدق لا تتم عملية الفلترة كما يجب
الف شكر تم حل المشكلةالاولى

المشكلة حاليا فى صفحة واحدة ساقوم برفعها مستقلة و احتاج فيها عدة معادلات سأوضحها فى الملف المرفوع

تم تعديل يونيو 3, 2019 بواسطه يوسف عطا

[يوسف عطا]

الملف الذى به دليل التظريف التلقائى

الفكرة إن فى كل إمتحان بيتم تظريف كراسات الإجابة خمسينات و مسلسلة حسب ارقام الجلوس لكن ممكن يكون فى طلبة معندهاش المادة فمابتتحسبش فى العدد

آخر مظروف فقط هو اللى مسموح فيه بوضع عدد كراسات إجابة أقل من 50

دليل التظريف.xls

[عادل حنفي]

السلام عليكم

اخي يوسف انا حاولت في ملفك علي حسب درجة فهمي للموضوع ووجدت حلا لا ادري اذا كان هذا الحل يفيد ام لا

ارجو تجربة الملف واخبرني بملاحظاتك

تحياتي

دليل التظريف.xlsm

[يوسف عطا]

الف شكر معلمنا الغالى عادل بك حنفى حفظك الله
جارى التجربة

 

بعد التجربة
======

الحل بتاع حضرتك كان بيعتمد على كتابة كل أرقام الجلوس للطلبة فى كل إمتحان من ال 15 امتحان اللى بيمتحنوهم يدوياً و بعد كدة هنطلع الأرقام بتاعة بداية و نهاية كل مظروف يدوياً برضه و المعادلة هتنقلهم فقط من صفحة العد اليدوى لصفحة دليل التظريف
وده هيكون موضوع مرهق لما يتعمل فى كل إمتحان على حدة خاصة إن فى ملحوظتين مهمين
1. ارقام الجلوس مش كلها سيريال واحد 
2. مش كل الطلبة عندهم جميع المواد
وبالتالى يبقى الحل ده مرهق جداً وكمان لن يخلوا من الخطأ لأنه بيعتمد على شغل يدوى
===== الحل من وجهة نظرى إن أمكن =======

كنت أفكر فى الإعتماد على رقم 1 اللى بيكون مكتوب بجوار كل رقم جلوس تحت اسم المواد اللى مقررة  على كل طالب

وده هيتكتب بمعادلة فنسبة الخطأ فيه تكاد تكون منعدمة

فتقوم المعادلات بعد أرقام ال 1 فى عمود كل مادة و لما توصل للرقم الخمسين تستدعى رقم الجلوس المقابل للطالب رقم 50 من صفحة دليل التظريف نفسها

ثم هكذا فى المظروف التالى تبدأ بعد الطالب رقم 51 فى العمود على أنه رقم 1 فى المظروف

======== حل آخر لو أمكن =========

بدل إستخدام معادلة لوضع رقم 1 فى عمود المادة للطالب المقررة عليه تلك المادة

نشوف معادلة تانية تعد الطلبة اللى عندهم المادة عد عادى 1 2 3 4 5 6 7 8 9  وهكذا حتى آخر العمود

المشكلة انى لما استخدمت المعادلة 

=IF(U2=0;"";RANK(T2;$T$2:$T$2000;1))

كان بيحسب الطلبة اللى معندهمش المادة فى الإحصاء مع أنه ماكانش بيديهم رقم ترتيبهم قصاد رقم الجلوس لكن بيعمل فجوة بين الارقام

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

يعنى نخلى عداد الترتيب التصاعدى مايعدش اللى معندهمش المادة

يعنى مايعدش اللى فى قصاد رقم الجلوس صفر فى عمود المادة

هل ده ممكن ؟؟

ثم عن طريق معادلة

=SMALL($T$2:$T$2000;1) 

=SMALL($T$2:$T$2000;50)

=SMALL($T$2:$T$2000;51)

=SMALL($T$2:$T$2000;100)

=SMALL($T$2:$T$2000;101)

=SMALL($T$2:$T$2000;150)

=SMALL($T$2:$T$2000;151)

=SMALL($T$2:$T$2000;200)

=SMALL($T$2:$T$2000;201)

=SMALL($T$2:$T$2000;217)

وهكذا

هنقدر نحدد بداية و نهاية كل مظروف بسهولة

===============حل آخر لكنه لازال ينقصه لمسة خبير==================

المعادلات دى إشتغلت معايا فى العربى و الدين و القومية فى كل المظاريف ما عدا الأخير 

لكنها لم تعمل جيداً فى المواد الأخرى 

=INDEX($T$2:$V$2000;1;1)

=INDEX($T$2:$V$2000;50;1)

=INDEX($T$2:$V$2000;51;1)

=INDEX($T$2:$V$2000;100;1)

=INDEX($T$2:$V$2000;101;1)

=INDEX($T$2:$V$2000;150;1)

=INDEX($T$2:$V$2000;151;1)

=INDEX($T$2:$V$2000;200;1)

=INDEX($T$2:$V$2000;201;1)

=INDEX($T$2:$V$2000;217;1)

 

 

مش عارف تعبت كتير ومش لاقى حل
شكراً لتعبك معايا استاذنا الكبير
وكل عام و أنتم بخير

بمناسبة عيد الفطر المبارك

 

تم تعديل يونيو 5, 2019 بواسطه يوسف عطا

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

ربما تنفع مجموع الأكواد هذه بجيث تختار المادة التي تريد

اذا كان الكومبوبوكس في الصفحة T فارغاً اخرج من الصفحة ثم عد اليها

Private Sub My_Combo_Change()
Rem ======>> Created By Salim Hasbaya On 5/6/2019
Tajriba
End Sub
Rem ====================================
Private Sub Worksheet_Activate()
Rem ======>> Created By Salim Hasbaya On 5/6/2019
fil_comBo
End Sub
Option Explicit
Rem ======>> Created By Salim Hasbaya On 5/6/2019
 Sub Tajriba()
Dim tt As Worksheet: Set tt = Sheets("T")
Dim M As Worksheet: Set M = Sheets("Matharive")
Dim Madda$: Madda = tt.Range("B2")
Dim col%, My_count
Dim x_ro%: x_ro = 5
Dim Y_col%: Y_col = 4
Dim Max_ro%, Frst_ad$, Act_ad$
Dim find_what As Range
Dim Searh_rg As Range
Dim t%
Dim Ro%
tt.Range("d5:v" & Rows.Count).ClearContents
Max_ro = M.Range("t1").CurrentRegion.Rows.Count
col = Sheets("MaTharive").Range("T1:ba1").Find(Madda).Column
Set Searh_rg = Sheets("MaTharive").Cells(1, col).Resize(Max_ro)
My_count = Application.CountIf(Searh_rg, Madda) - 1

Set find_what = Searh_rg.Find(Madda)
 If find_what Is Nothing Then Exit Sub
  Act_ad = Searh_rg.Find(Madda).Address
  Frst_ad = Act_ad
  Ro = find_what.Row
   Do
    t = t + 1
    If t > My_count Then Exit Do
     tt.Cells(x_ro, Y_col) = M.Cells(Ro, "T")
    x_ro = x_ro + 1
    If x_ro = 55 Then x_ro = 5: Y_col = Y_col + 1
    Set find_what = Searh_rg.FindNext(find_what)
    Act_ad = find_what.Address
    Ro = find_what.Row
    If Act_ad = Frst_ad Then Exit Do
   Loop
End Sub
Rem==================================
Sub fil_comBo()
Dim MY_Array(1 To 18)
Dim i
MY_Array(1) = 21: MY_Array(2) = 25: MY_Array(3) = 27
MY_Array(4) = 29: MY_Array(5) = 31: MY_Array(6) = 33
MY_Array(7) = 35: MY_Array(8) = 37: MY_Array(9) = 38

MY_Array(10) = 40: MY_Array(11) = 42: MY_Array(12) = 43
MY_Array(13) = 45: MY_Array(14) = 46: MY_Array(15) = 47
MY_Array(16) = 49: MY_Array(17) = 50: MY_Array(18) = 51
For i = 1 To 18
  MY_Array(i) = _
  Sheets("MaTharive").Cells(1, MY_Array(i))
 Next
Sheets("t").My_Combo.List = Application.Transpose(MY_Array)
Erase MY_Array
End Sub

الملف مرفق

 

Dalil.xlsm

[عادل حنفي]

الان فهمت ماتريده تقريبا وقد تذكرت دالة كان عاملها القدير ابو تامر اسمها VLOOK2ALL

ولكن يشترط نقل العامود الذي تضع فيه 1 للعد قبل عامود رقم الجلوس

والدالة مرقفة في الملف في مديول

جرب كده اعتقد انها ستحل المشكلة

دليل التظريف.xlsm

[يوسف عطا]

7 hours ago, سليم حاصبيا said:

ربما تنفع مجموع الأكواد هذه بجيث تختار المادة التي تريد

اذا كان الكومبوبوكس في الصفحة T فارغاً اخرج من الصفحة ثم عد اليها

Private Sub My_Combo_Change()
Rem ======>> Created By Salim Hasbaya On 5/6/2019
Tajriba
End Sub
Rem ====================================
Private Sub Worksheet_Activate()
Rem ======>> Created By Salim Hasbaya On 5/6/2019
fil_comBo
End Sub
Option Explicit
Rem ======>> Created By Salim Hasbaya On 5/6/2019
 Sub Tajriba()
Dim tt As Worksheet: Set tt = Sheets("T")
Dim M As Worksheet: Set M = Sheets("Matharive")
Dim Madda$: Madda = tt.Range("B2")
Dim col%, My_count
Dim x_ro%: x_ro = 5
Dim Y_col%: Y_col = 4
Dim Max_ro%, Frst_ad$, Act_ad$
Dim find_what As Range
Dim Searh_rg As Range
Dim t%
Dim Ro%
tt.Range("d5:v" & Rows.Count).ClearContents
Max_ro = M.Range("t1").CurrentRegion.Rows.Count
col = Sheets("MaTharive").Range("T1:ba1").Find(Madda).Column
Set Searh_rg = Sheets("MaTharive").Cells(1, col).Resize(Max_ro)
My_count = Application.CountIf(Searh_rg, Madda) - 1

Set find_what = Searh_rg.Find(Madda)
 If find_what Is Nothing Then Exit Sub
  Act_ad = Searh_rg.Find(Madda).Address
  Frst_ad = Act_ad
  Ro = find_what.Row
   Do
    t = t + 1
    If t > My_count Then Exit Do
     tt.Cells(x_ro, Y_col) = M.Cells(Ro, "T")
    x_ro = x_ro + 1
    If x_ro = 55 Then x_ro = 5: Y_col = Y_col + 1
    Set find_what = Searh_rg.FindNext(find_what)
    Act_ad = find_what.Address
    Ro = find_what.Row
    If Act_ad = Frst_ad Then Exit Do
   Loop
End Sub
Rem==================================
Sub fil_comBo()
Dim MY_Array(1 To 18)
Dim i
MY_Array(1) = 21: MY_Array(2) = 25: MY_Array(3) = 27
MY_Array(4) = 29: MY_Array(5) = 31: MY_Array(6) = 33
MY_Array(7) = 35: MY_Array(8) = 37: MY_Array(9) = 38

MY_Array(10) = 40: MY_Array(11) = 42: MY_Array(12) = 43
MY_Array(13) = 45: MY_Array(14) = 46: MY_Array(15) = 47
MY_Array(16) = 49: MY_Array(17) = 50: MY_Array(18) = 51
For i = 1 To 18
  MY_Array(i) = _
  Sheets("MaTharive").Cells(1, MY_Array(i))
 Next
Sheets("t").My_Combo.List = Application.Transpose(MY_Array)
Erase MY_Array
End Sub

الملف مرفق

 

Dalil.xlsm 328.97 kB · 4 downloads

استاذنا الغالى سليم بك حاصبيا حفظك الله
للاسف الكود لم يعمل معى ربما لأنى أعمل على أوفيس 2003 أو لا أدرى السبب فلم استطع التجربة
جازاك الله خيراً على تعبك معايا وجعل عملك فى موازين حسناتك

[يوسف عطا]

4 hours ago, عادل حنفي said:

الان فهمت ماتريده تقريبا وقد تذكرت دالة كان عاملها القدير ابو تامر اسمها VLOOK2ALL

ولكن يشترط نقل العامود الذي تضع فيه 1 للعد قبل عامود رقم الجلوس

والدالة مرقفة في الملف في مديول

جرب كده اعتقد انها ستحل المشكلة

دليل التظريف.xlsm 314.2 kB · 3 downloads

أستاذنا الكبير عادل بك حنفى حفظك الله

بالفعل هذا الموديول و المعادلة الجميلة لأخونا الغالى ابو تامر ربنا يطمنا عليه ويمسيه بالخير افادت كثيراً فى حل المشكلة
و الدال على الخير كفاعله فالشكر موصول لك وله
وبعد إذنك قمت بتعديل بسيط فى المعادلات مع بعض التنسيقات الشرطية فأصبح دليل التظريف بالفعل عمل محترفين وهذا ليس غريب أو جديد عليكم فلازال ملف ساقية توزيع الملاحظين على لجان الإمتحان الذى قدمتموه منذ عدة سنوات عملاً جميلاً و إن كنا نأمل فى تطويره تطويراً بسيطاً حيث فى بعض الأوقات لا ينفذ جميع الشروط وعموماً ليس هذا مجاله الآن
وعلى كل حال مرفق ملف دليل التظريف للإطلاع و تقديم الملاحظات و ربنا يجعل أعمالك فى موازين حسناتك 
وكل عام و أنتم بخير

و لنعتبر الملف هدية لجميع المهتمين بكنترولات لجان الثانوية العامة 
وتقبلوا تحياتى

دليل التظريف بمعادلة فى لوك تو أول.xls

[عادل حنفي]

اخي يوسف

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

وهو ابو تامر كتبه الله له في ميزان حسناته وكتب الله لك حسنات من يسبفيد بملفك

بخصوص ساقية توزيع الملاحظين من الجيد ان اعلم انه مازال يعمل بالرغم من قيامي وقتها بعمل اجزاء فيه لم اكن

مقتنعا بعملها لكنها كانت تحل بعض المشاكل وقد كان الوقت هذه الايام به من الفراغ ما يسمح لعمل ذلك اما الان

احاول وجود الوقت للمشكلات السريعة الحل قدر الامكان

خالص تحياتي ولكل اسرة هذا المنتدي العظيم وكل عام وانتم بخير

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

3 ساعات مضت, يوسف عطا said:

أستاذنا الكبير عادل بك حنفى حفظك الله

بالفعل هذا الموديول و المعادلة الجميلة لأخونا الغالى ابو تامر ربنا يطمنا عليه ويمسيه بالخير افادت كثيراً فى حل المشكلة
و الدال على الخير كفاعله فالشكر موصول لك وله
وبعد إذنك قمت بتعديل بسيط فى المعادلات مع بعض التنسيقات الشرطية فأصبح دليل التظريف بالفعل عمل محترفين وهذا ليس غريب أو جديد عليكم فلازال ملف ساقية توزيع الملاحظين على لجان الإمتحان الذى قدمتموه منذ عدة سنوات عملاً جميلاً و إن كنا نأمل فى تطويره تطويراً بسيطاً حيث فى بعض الأوقات لا ينفذ جميع الشروط وعموماً ليس هذا مجاله الآن
وعلى كل حال مرفق ملف دليل التظريف للإطلاع و تقديم الملاحظات و ربنا يجعل أعمالك فى موازين حسناتك 
وكل عام و أنتم بخير

و لنعتبر الملف هدية لجميع المهتمين بكنترولات لجان الثانوية العامة 
وتقبلوا تحياتى

دليل التظريف بمعادلة فى لوك تو أول.xls 492 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 3 downloads

الملف بصيغة 2003

اذا كان الكومبوبوكس في الصفحة T فارغاً اخرج من الصفحة ثم عد اليها

DALIM.xls

[يوسف عطا]

On 6/5/2019 at 6:28 PM, سليم حاصبيا said:

الملف بصيغة 2003

اذا كان الكومبوبوكس في الصفحة T فارغاً اخرج من الصفحة ثم عد اليها

DALIM.xls 1.03 MB · 4 downloads

الأستاذ الكبير سليم حاصبيا
السلام عليكم وكل سنة ونت طيب

الفكرة جميلة و تعمل جيدا
ولكن
1. الكومبو بوكس يستخرج كل مادة على حدة و فى بعض الإمتحانات تكون هناك أكثر من مادة يمتحنها الطلاب معاً فطالب يمتحن تاريخ و زميله فى نفس اللجنة ونفس الوقت يمتحن فيزياء و عند التظريف لابد أن تكون جميع الأوراق فى نفس المظروف
2. لم استطع نقل الفكرة للملف الذى أعمل عليه
3. أكثر ما يهمنى هو أول رقم جلوس فى المظروف و آخر رقم جلوس فى نفس المظروف و عدد الكراسات فى المظروف الأخير لأنه متغير
جوزيت خيراً و حسب الله اعمالك فى موازين حسناتك