ناصر سعيد

اولا اشكرك كثيرا استاذ محمد طاهر ثانيا اذا كان التعطيل بسبب من المنتدى فارجو ازاله هذا السبب عن حسابات الجميع

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

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

اخي الكريم الاستاذ المحترم زيزو السلام عليكم ورحمة الله وبركاته ان شاء الله سيكون افضل واول كود بالمصفوفات لتوزيع اللجان على مستوى المنتديات بارك الله فيك الكود يعمل جيدا وسريع ولكنه ياتي فقط باللجنتين الاوليين فقط ثانيا لو تم توزيع عدد كل لجنه اوتوماتيك بمعنى ها اكتب عدد اللجان المطلوبه والكود يوزعهم بالتساوي ربنا يبارك فيك ... يارب ================ كودكم الرائع بيقف عند عدد طلاب اللجنه 22 طالب فقط يعني لو كتبت عدد طلاب لجنه 25 مثلا وشوف لاتمتد التسطيره بالعدد المطلوب يحفظكم الخالق

هذا عمل رائع للمحترم ياسر العربي .. خاص بتوزيع الطلاب على اللجان بطريقه المصفوفات السريعه ولكنه ياتي بلجنه واحده في الصفحه فمن من الافذاذ الذي يجعل هذا الكود يوزع اللجان على نصفي الورقه Sub Yasser() Dim myarr() Dim a, b, c, m, n, o a = Sheets("كشوف المناداة").Range("E2") b = Application.WorksheetFunction.Count(Sheets("بيانات الطلبة").Range("B7:B2000")) z = b / a n = Int(z) m = Round((z - n) * a, 1) Range("B9:F9").ClearContents Range("B10:F" & Cells(Rows.Count, 2).End(xlUp).Row + 2).Clear myarr() = Sheets("بيانات الطلبة").Range("B7:P" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value ReDim y(1 To UBound(myarr, 1) + (a * n), 1 To 5) For x = LBound(myarr) To UBound(myarr) rw = rw + 1 rr = rr + 1 y(rw, 1) = rr: y(rw, 2) = myarr(x, 1) y(rw, 3) = myarr(x, 4): y(rw, 4) = myarr(x, 14) y(rw, 5) = myarr(x, 15) If m > 0 And rr = n + 1 Then m = m - 1 rr = 0 rw = rw + 8 ElseIf m <= 0 And rr = n Then rr = 0 rw = rw + 8 End If Next x Range("B9:F9").AutoFill Destination:=Range("B9:F" & b + (a * 8) + 8), Type:=xlFillDefault If rw > 0 Then Cells(Rows.Count, 2).End(xlUp)(2, 1).Resize(rw, 5).Value = y() Range("T3:X10").Copy Range("B9:F" & Cells(Rows.Count, 2).End(xlUp).Row + 8).SpecialCells(xlCellTypeBlanks).Select ActiveSheet.Paste Range("B" & Cells(Rows.Count, 2).End(xlUp).Row - 6 & ":F" & Cells(Rows.Count, 2).End(xlUp).Row + 6).Clear 88 End Sub كتبها الله لكم في كفة حسناتكم توزيع اللجان للعبقري ياسر العربي.rar

للرفع

للرفع

Sub Alsaqer3() Range("A1:C1").Copy Destination:=Range("h1") End Sub ممتازة بارك الله فيك لو اردنا ان يتم النسخ بعدد صفوف محدده .. كيف ؟ جزاك الله خيرا =========== وماذا لو كانت خلايا متفرقه مطلوب نسخها الى مكان اخر ب Destination

اين توجد هذه القائمه

بارك الله بك وبجهودك

استخراج شهادات الطلاب بمعيه رقم الجلوس .. فكره جديده شهادات 2.rar ================ =MATCH($J4;INDEX(KH_RANG;0;2);0) =INDEX(KH_RANG;$M4;3)

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

القيم الفريده بطريقتين للمحترم عبد الله باقشير والمحترم ياسر خليل 'Private Sub Worksheet_Activate() Sub القــيم_الفريده() 'Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'مسح عمود القيم الفريده [S9:S500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [S9:S500] 'اسم شيت المصدرورقم صف البدايه في شيت الهدف For U = 9 To Sheets("بيانات الطلبة").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر Cells(U, 19) = Sheets("بيانات الطلبة").Cells(U, 22) 'رقم عمودالبيانات الفريده في الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 19)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 19).ClearContents End If Next 'فرز عمود القيم الفريده [S9:S500].Sort [S9], xlAscending Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Unique_List() 'هذاالكود خاص بالمحترم ياسر خليل 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 28/04/2017 'تعريف المتغيرات Dim Rng As Range Dim Cel As Range Dim Coll As New Collection Dim I As Integer 'تعيين النطاق المراد استخراج القيم الفريدة منه Set Rng = Sheets("بيانات الطلبة").Range("V7:V" & Sheets("بيانات الطلبة").Cells(Rows.Count, 1).End(xlUp).Row) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'سطر لتجنب حدوث خطأ لأنه عند إضافة عنصر موجود من قبل يحدث خطأ On Error Resume Next 'حلقة تكرارية لكل خلية من خلايا النطاق For Each Cel In Rng 'إضافة العنصر أو قيمة الخلية ويمثل الجزء بعد الفاصلة مفتاح فريد 'لتحويل قيمة الخلية لقيمة نصية في حالة التعامل مع الأرقام [Cstr] وتم استخدام الدالة Coll.Add Cel.Value, CStr(Cel.Value) Next Cel 'وضع قيم الكائن الذي استخدم في تخزين القيم الفريدة في العمود الثالث For I = 1 To Coll.Count Sheets("اوائل ").Cells(I + 8, 19).Value = Coll(I) Next I Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub القيم الفريــده.rar

للرفع

المحترم الاستاذ محمد طاهر السلام عليكم ورحمة الله لماذا لايظهر ارسال رساله ؟ الصورة توضح اكثر ========== بجوار ايجاد المحتوى

شكرا لسعة صدرك استاذ محمد صالح وشكرا للاستاذ سليم حاصبيا

=INDEX(Sheet1!$A$2:$A$1000; MATCH(0; COUNTIF($D$1:D5; Sheet1!$A$2:$A$1000); 0)) شكرا لسعة صدركم .. المشكله كانت الفاصله هل يمكن ازاله الخطأ الذي يظهر عند وجود المعادله وعدم وجود قيم فريده اخرى

تم فتح شيت جديد في ورقة sheet1 وفي العمود A وفي الخليه التانيه وضعنا ارقام عشوائيه مكرره وفي الورقه التانيه وضعنا معادلتك ... من فضلك اين الخطأ في الخطوات ؟

الاستاذ المحترم محمد صالح جزاك الله خيرا تعطي هذه الرساله

الاستاذ الكبير محمد صالح ... بارك الله فيك وحفظك من كل سوء من فضلك ضع ملفا لمعادلتك بشرط ان يكون النتائج في صفحة مختلفه عن صفحة البيانات

بسم الله الرحمن الرحيم استخراج القيم الفريده بطريقة العلامه عبد الله باقشير .. حفظه الله ورعاه مع شرح الكود جزى الله كل من ساهم في اخراج هذا العمل الى النور بكل خير Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False 'مسح عمود القيم الفريده [V5:V500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [V5:V500] 'اسم شيت المصدرورقم صف البدايه في شيت المصدر For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4) 'رقم عمودالبيانات الفريدهفي الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 22)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 22).ClearContents End If Next 'فرز عمود القيم الفريده [V5:V500].Sort [V5], xlAscending Application.ScreenUpdating = True End Sub استخراج القيم الفريده.rar

بسم الله الرحمن الرحيم استخراج القيم الفريده بطريقة العلامه عبد الله باقشير .. حفظه الله ورعاه مع شرح الكود جزى الله كل من ساهم في اخراج هذا العمل الى النور بكل خير Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False 'مسح عمود القيم الفريده [V5:V500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [V5:V500] 'اسم شيت المصدرورقم صف البدايه في شيت المصدر For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4) 'رقم عمودالبيانات الفريدهفي الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 22)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 22).ClearContents End If Next 'فرز عمود القيم الفريده [V5:V500].Sort [V5], xlAscending Application.ScreenUpdating = True End Sub استخراج القيم الفريده.rar

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

شهادات رائعه بمعيه الناجحين او الرسبين او الاولاد او البنات او الفصول وغيره للمبدعه ساجده العزاوي العراقيه شهادات الطلاب بمعايير مختلفه .. لساجده العزاوي.rar ''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' ' هذا الكود للنابغه ساجده العزاوي ' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه 'تم في 27 يونيو 2016 'كمعطيات المحترم ابو أحمد محمدي ''الفكرة هنا اشرحها باختصار ''ناخذ متغير ونضيف له بعد مليء البيانات 1 '' '' فاذا المتغير زوجي نضع البيانات في الشهادة العلوية بالورقة '' واذا فردي نضع البيانات في الشهادة السفلية بالورقة '' وعند امتلاء الشهادتين نطبع الورقة '' ويتكرر اللوب.... اما اذا كانت فردية بالنهاية '' نجيك هل خلية ام 19 فارغة معناها فقط الشهادة العلوية ممتلئة '' وبهذا نعرف انها فردية فنطبعها Sub محددة_ناجحون() ' هذا الكود للنابغه ساجده العزاوي ' وهي من أهلنا بالعراق أعز الله العراق وأذل أعداءه 'تم في 27 يونيو 2016 'كمعطيات المحترم ابو أحمد محمدي ' متغيرات يجب تعريفها Const studentData As String = "رصد الترم الثانى" Const shehada As String = "شهادة" '================ lr = Sheets(studentData).Range("C7").End(xlDown).Row ' ايجاد اخر صف موجود به بيانات c = 2 'فائدتها اذا كانت زوجي يضع البيانات في الشهادة العلوية 'واذا فردي يضع البيانات في الشهادة السفلية بالورقة '==== 'هذه الجزئيه خاصه بجميع الطلاب ( ناجحون ودور تان) 'For i = 7 To LR '==== 'هذه الجزئيه خاصه بطباعة شهادات محدده For i = Sheets(shehada).Cells(7, 18).Value _ To Sheets(shehada).Cells(7, 19).Value 'من الخلية التي تحوي رو الطبع الى الخلية الثانية التي تحوي الى ار 7 و اس 7 Application.ScreenUpdating = False 'لتسريع الكود وعدم رؤية مايحدث في الشيت وبذلك يتم اخفاء الرجفة If c Mod 2 = 0 Then 'نقسم السي على 2 اذا الباقي صفر اذن سي رقمها زوجي ... 'اذا كان زوجي نضع البيانات في الشهادة العلوية If Sheets(studentData).Cells(i, 157) Like "*" & "ناج*" & "*" Then '''If Sheets(StudentData).Cells(i, 157) = "ناجح" Or _ Sheets(StudentData).Cells(i, 157) = "ناجحة" Then 'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها ' Sheets(shehada).Cells(3, 13) = Sheets(studentData).Cells(i, 2) 'متغير نضع رقم الجلوس في الخلية ام 3 وعند وضعه 'ستظهر البيانات في الخلايا التي وضعنا فيها المعادله Sheets(shehada).Cells(12, 3) = Sheets(studentData).Cells(i, 157) Sheets(shehada).Cells(12, 6) = Sheets(studentData).Cells(i, 158) 'نضع محتوى الخلايا سواء فيها ناجح ناجحة 'او لها له دور ثاني ومنقول لصف في الخلايا اعلاه ' ' c = c + 1 'نزيد العداد حتى يصبح فردي ' وفي اللوب الثاني يذهب الى الشهادة التحت لان العليا ملأناها ' ' End If GoTo 1 'يذهب الى 1 لاخذ رقم جلوس اخر Else 'اذا كان رقم السي فردي If Sheets(studentData).Cells(i, 157) Like "*" & "ناج*" & "*" Then 'If Sheets(StudentData).Cells(i, 157) = "له دور ثان في" Or _ Sheets(StudentData).Cells(i, 157) = "لها دور ثان في" Then 'رقم عمود المعيار وكلمه المعيار الذي نبحث عنها Sheets(shehada).Cells(19, 13) = Sheets(studentData).Cells(i, 2) Sheets(shehada).Cells(28, 3) = Sheets(studentData).Cells(i, 157) Sheets(shehada).Cells(28, 6) = Sheets(studentData).Cells(i, 158) c = c + 1 Sheets(shehada).Range("a1:p31").PrintOut 'وضعنا الطبع هنا في الاف الثانية وليس الاف الاولى للزوجي 'لان تأكدنا تم مليء الشهادتين بالبيانات ' ' Sheets(shehada).Cells(3, 13) = "" Sheets(shehada).Cells(19, 13) = "" 'بعد الطبع يجب تفريغ الخليتين ام3 و ام 19 ' التي تحوي ارقام الجلوس ' ' End If End If 1: Next i If Sheets(shehada).Cells(19, 13) = "" And Sheets(shehada).Cells(3, 13) <> "" Then Sheets(shehada).Range("a1:p15").PrintOut End If 'هذه الاف وضعناها في حالة شهادة فردية ' ففي حالة ام 19 فارغة معناها شهادة فردية فقط 'الشهادة العلوية فيها بينات ونعطيه امر بطبعها Application.ScreenUpdating = True End Sub '''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''

تمام حفظكم الله استاذ محمد طاهر .. تم الحل