قصي

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

احبابي الاساتذه الكرام المشركة رقم 4 بها الكود والصفحة جزاكم الله خيرا

هذا هو الكود الذي يجعل عدد ارقام الجلوس غي اعلا الصفحة 2 اين جزئيه التغيير لكي نجعل عدد ارقام الجلوس في اعلا الصفحة 3 Sub ترحيل() On Error Resume Next Application.ScreenUpdating = False Range("B13:P4503").ClearContents تنسيق AA = Range("صف").Value E = Range("نصف_الطلبة").Value U = 5 R = 6 For M = 1 To E Y = 2 For N = 1 To 3 Cells(U, Y + 5) = " رقم اللجنة / " & Sheets("بيانات أساسية").Cells(R, 20) Cells(U + 3, Y) = " الاسم / " & Sheets("بيانات أساسية").Cells(R, 5) Cells(U + 4, Y) = " رقم الجلوس / " & Sheets("بيانات أساسية").Cells(R, 2) Y = 10 R = R + 1 Next N U = U + 9 R = R Next M ActiveSheet.PageSetup.PrintArea = "$B$4:$P$" & AA Application.ScreenUpdating = True On Error GoTo 0 End Sub

الحمد لله . الحمد لله الذي شرفنا بالاستاذ العظيم والاخ الكريم الدرة ( الماس ) محمد صالح الكود المرفق في المشاركة رقم 5 يجلب بيانات ارقام الجلوس بدون كتابة اي معادلات في ورقة ارقام الجلوس ولكنه يستدعي البيانات لعدد 2 رقم جلوس في اعلا الصفحة ونحن نريدها 3 ارقام في اعلا الصفخة مثل الموجوده بالمرفق في المشاركة الاولى باسم ارقام الجلوس لكي نوفر في الورق ولان المرفق المشار اليه باسم ارقام الجلوس لو قطعنا صفحة الطباعه الى 9 ارقام لوجدتها متساويه المقاسات ... هذا و لشخصكم الكريم الف الف تحيه

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

وعقبال عودة لاستاذ الكبير عبد الله المجرب وعودة اساتذة المنتدى الغائبين ردهم الله الى اهلهم بالمنتدى سالمين غانمين

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

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

ونعم الناس الله يبارك فيك وفيه وفي الاخوة النافعين

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

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

بارك الله لك يا استاذ ابن مصر ولي سؤال مامعنى هذه الارقام ال6 والرقم 8 لو تكرمت اشرح الكود وياسلام لو خليت هذا الكود بالطريقه السهله مثل هذه البدايه Const StudentData As String = "بيانات الطلبة" Const TopStudents As String = "الاوائل"

جزاك الله خيرا وبارك لك الاستاذ الفاضل ابن مصر وهذا هو الملف الاصلي توزيع الطلاب1.rar

بسم الله الرحمن الرحيم احبابنا في الخير لاحظت في بعض الاكواد بدايه فيها اكثر من رائعه وهي اننا نستطيع نقل الكود بسهوله منقطعة النظير مع تغيير المعطيات في اول الكود مثل هذه البدايه على سبيل المثال Const StudentData As String = "بيانات الطلبة" Const TopStudents As String = "الاوائل" ادعو الله ان يوفقنا الى اضافة هذه الميزة على هذا الكود الخاص بالعلامه عبد الله باقشير Sub KH_START() On Error Resume Next Dim MyRang_1 As Range, MyRang_2 As Range, MyRang_Formats As Range Dim S As Integer, E As Integer, W As Integer, V As Integer, T As Integer, TT As Integer _ , H As Integer, M As Integer, Y As Integer, Z As Integer, N As Integer, U As Integer _ , R As Integer, C As Integer, CC As Integer, O As Integer, EE As Integer, SS As Integer '======================================= If [B2] = False Then MsgBox "تاكد من الشرط في الخلية B2", vbMsgBoxRtlReading, "تنبيه": GoTo 1 '======================================= 'اسم ورقة مصدر البيانات S = Application.CountA(ورقة1.Range("B6:B1005")) ' عددالطلبة E = [E2] ' عدد طلاب اللجنة T = Application.RoundUp(S / (E * 3), 0) ' عدد الكشوفات TT = Application.RoundUp(S / E, 0) W = 7 ' عدد الصفوف الخارجة عن التوزيع في ورقة الكشوفات V = 5 ' عدد الصفوف الخارجة عن التوزيع في ورقة البيانات H = E + 4 + 3 ' عدد طلاب اللجان زايدا رؤؤس الاعمدة والتذييل Set MyRang_1 = Range("راس_اللجان") Set MyRang_2 = Range("تذييل_اللجان") Set MyRang_Formats = Range("فورمات") KH_Clear '================================ Application.ScreenUpdating = False ActiveWindow.View = xlPageBreakPreview '================================ For M = 1 To T If M <> 1 Then MyRang_1.Copy Range("B" & W - 3) Set ActiveSheet.HPageBreaks(M - 1).Location = Range("B" & W - 3) End If Y = 2 For Z = 1 To 3 EE = Application.RoundUp((S - (V - 5)) / (TT - SS), 0) SS = SS + 1 MyRang_Formats.Copy Cells(W + 1, Y).Resize(E, 5).PasteSpecial xlPasteFormats Application.CutCopyMode = False MyRang_2.Copy Cells(W + E + 1, Y) For N = 1 To EE U = N + W: R = N + V For C = 1 To 4 CC = Choose(C, 11, 2, 8, 10) 'اسم ورقة مصدر البيانات Cells(U, Y + C) = ورقة1.Cells(R, CC) Next C If Cells(U, Y + 1) <> "" Then Cells(U, Y) = N Next N V = V + EE: Y = Y + 6 Next Z W = W + H Next M '================================ ActiveWindow.View = xlNormalView With ActiveSheet O = .UsedRange.Rows.Count .PageSetup.PrintArea = .Range("B4:R" & O).Address End With '================================ Application.ScreenUpdating = True Range("A4").Activate معاينة On Error GoTo 0 1 End Sub Sub KH_Clear() Dim Y As Integer Application.ScreenUpdating = False 'اسم ورقة كشوفات اللجان With ورقة2 Y = .UsedRange.Rows.Count + 8 .Range("B8:R" & Y).Delete .PageSetup.Zoom = 92 .PageSetup.PrintArea = .Range("B4:R1000").Address End With End Sub Sub معاينة() ActiveWindow.SelectedSheets.PrintPreview End Sub جزاكم الله خيرا

بارك الله فيكم يارب اريد شرح لهذا الكود وفي هذه الحالة سيتم اكتشاف الخطأ في توزيع عدد طلاب كل لجنه هذا هو الكود الاصلي للعلامة عبد الله باقشير Sub KH_START() On Error Resume Next Dim MyRang_1 As Range, MyRang_2 As Range, MyRang_Formats As Range Dim S As Integer, E As Integer, W As Integer, V As Integer, T As Integer, TT As Integer _ , H As Integer, M As Integer, Y As Integer, Z As Integer, N As Integer, U As Integer _ , R As Integer, C As Integer, CC As Integer, O As Integer, EE As Integer, SS As Integer '======================================= If [B2] = False Then MsgBox "تاكد من الشرط في الخلية B2", vbMsgBoxRtlReading, "تنبيه": GoTo 1 '======================================= 'اسم ورقة مصدر البيانات S = Application.CountA(ورقة1.Range("B6:B1005")) ' عددالطلبة E = [E2] ' عدد طلاب اللجنة T = Application.RoundUp(S / (E * 3), 0) ' عدد الكشوفات TT = Application.RoundUp(S / E, 0) W = 7 ' عدد الصفوف الخارجة عن التوزيع في ورقة الكشوفات V = 5 ' عدد الصفوف الخارجة عن التوزيع في ورقة البيانات H = E + 4 + 3 ' عدد طلاب اللجان زايدا رؤؤس الاعمدة والتذييل Set MyRang_1 = Range("راس_اللجان") Set MyRang_2 = Range("تذييل_اللجان") Set MyRang_Formats = Range("فورمات") KH_Clear '================================ Application.ScreenUpdating = False ActiveWindow.View = xlPageBreakPreview '================================ For M = 1 To T If M <> 1 Then MyRang_1.Copy Range("B" & W - 3) Set ActiveSheet.HPageBreaks(M - 1).Location = Range("B" & W - 3) End If Y = 2 For Z = 1 To 3 EE = Application.RoundUp((S - (V - 5)) / (TT - SS), 0) SS = SS + 1 MyRang_Formats.Copy Cells(W + 1, Y).Resize(E, 5).PasteSpecial xlPasteFormats Application.CutCopyMode = False MyRang_2.Copy Cells(W + E + 1, Y) For N = 1 To EE U = N + W: R = N + V For C = 1 To 4 CC = Choose(C, 11, 2, 8, 10) 'اسم ورقة مصدر البيانات Cells(U, Y + C) = ورقة1.Cells(R, CC) Next C If Cells(U, Y + 1) <> "" Then Cells(U, Y) = N Next N V = V + EE: Y = Y + 6 Next Z W = W + H Next M '================================ ActiveWindow.View = xlNormalView With ActiveSheet O = .UsedRange.Rows.Count .PageSetup.PrintArea = .Range("B4:R" & O).Address End With '================================ Application.ScreenUpdating = True Range("A4").Activate معاينة On Error GoTo 0 1 End Sub Sub KH_Clear() Dim Y As Integer Application.ScreenUpdating = False 'اسم ورقة كشوفات اللجان With ورقة2 Y = .UsedRange.Rows.Count + 8 .Range("B8:R" & Y).Delete .PageSetup.Zoom = 92 .PageSetup.PrintArea = .Range("B4:R1000").Address End With End Sub Sub معاينة() ActiveWindow.SelectedSheets.PrintPreview End Sub

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

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

معذره اخي الكريم اذا كان الملف المراد النقل اليه به حمايه فإن الكود يتعطل نرجو حلا

السلام عليكم ورحمة الله هذا ملف به صفحة ببيانات الطلاب وصفحة اخري بها استدعاء للطلاب ولكن عند كتابة العدد 19 او 11 تاتي النتائج خطأ ولااعرف السبب توزيع الطلاب1.rar

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

ربنا يبارك لك اخي الكريم الاستاذ ابو تراب لي رجاء ارجو تنفيذ الكود على هذا الملف لانه لايعمل عند نقله في هذا الملف فلترة متقدمة.rar

الاستاذ الفاضل ابو تراب اشكرك كثيرا وبعد الملف لايعمل عند فتح شيت 3 امسح الخلايا الموجوده في شيت 3 ثم افتح شيت 1 وبعدها افتح شيت 3 تجد لاشيئ

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

العمود المطلوب عدم التكرار فيه الموجود في شيت1 في العمود T

السلام عليكم ورحمة الله وبركاته يوجد في شيت 1 اسماء فصول مختلفه اريدها كرما منكم مفلتره كما في شيت 3 فلترة.rar