ياسر خليل أبو البراء

أخي الكريم أبو تيم هل الأرقام تبدأ في الخلية A2 في العمود الأول في أوراق العمل الأربعة .. سؤال آخر : هل الأرقام في ورقة العمل الواحدة مكررة أم أنها غير مكررة في ورقة العمل الواحدة؟

أخي الكريم أشرف .. وهشام كمال الأخ الحبيب المتابع للموضوع من بدايته أخي وحبيبي علاء رسلان إليكم إصدار أفضل من الدالة المعرفة .. وبالمثال يمكنكم التعامل مع أي بيانات إن شاء الله Public Function Wish(RngData As Range, RngWish As Range, Start_WishColumn As Long, End_WishColumn, MarkColumn As Long) Dim ArrData, ArrWish, ArrOut, ArrSwap Dim ColCount As Long, I As Long, J As Long, K As Long ArrData = RngData.Value ArrWish = RngWish.Value For I = 1 To UBound(ArrWish, 1) ArrWish(I, 2) = ArrWish(I, 2) Next I ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1) ColCount = UBound(ArrData, 2) ReDim ArrSwap(1 To 1, 1 To ColCount) For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, MarkColumn) > ArrData(I, MarkColumn) Then For J = 1 To ColCount ArrSwap(1, J) = ArrData(I, J) ArrData(I, J) = ArrData(K, J) ArrData(K, J) = ArrSwap(1, J) Next J End If Next K Next I For I = 1 To UBound(ArrData, 1) For J = Start_WishColumn To End_WishColumn If ArrOut(I, 1) = "" Then For K = 1 To UBound(ArrWish, 1) If ArrData(I, J) = ArrWish(K, 1) Then If ArrWish(K, 2) > 0 Then ArrOut(I, 1) = ArrWish(K, 1) ArrWish(K, 2) = ArrWish(K, 2) - 1 End If End If Next K End If Next J Next I For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, 1) < ArrData(I, 1) Then ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1) ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1) ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2) End If Next K Next I Wish = ArrOut End Function يتم تحديد النطاق الذي تريد النتائج به S8:S27 ثم في شريط المعادلات ضع المعادلة التالية =Wish(D8:R27,U12:V23,3,14,15) ثم اضغط على Ctrl + Shift + Enter البارامترات الخاصة بالمعادلة : البارامتر الأول : نطاق البيانات بالكامل D8:R27 البارامتر الثاني : نطاق الرغبات والذي يحتوي على الرغبات والحد الأقصى المسموح به البارامتر الثالث: عمود بداية الرغبات وهو في المثال العمود رقم 3 والعد يبدأ من بداية نطاق البيانات .. أي أن العد في المثال يبدأ من العمود D البارامتر الرابع: عمود نهاية الرغبات وهو في المثال العمود رقم 14 وكما أخبرنا العد يبدأ من بداية نطاق البيانات البارامتر الخامس والأخير: هو رقم عمود المجموع وهو في المثال رقم 15 وكما أخبرنا ونؤكد أن العد من بداية نطاق البيانات لا تنسونا من صالح دعائكم Pupils Distribution According To Marks & Wishes V2.rar

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

أخي الكريم أشرف إليك الملف التالي عله يفي بالغرض Pupils Distribution According To Marks & Wishes.rar

الأخ الكريم هشام كمال أعتذر عن التأخر في الرد إليك الملف التالي عله يفي بالغرض ماستر 2015-2016.rar

أخي الكريم أهلا ومرحباً بك في المنتدى بداية المشاركات ملف تنفيذي تم الكشف عنه على موقع Virus Total وها هو رابط نتيجة الفحص لمن يريد الإطلاع من هنا

يرجى طرح موضوع جديد بطلبك ليستفيد منه الجميع تقبل تحياتي

إذا كنت تعتبر الإشراف بالمنتدى ومراعاة الموضوعات وحذف المكرر منها إهانة .. فعذراً أخي الكريم أعتذر إليك

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

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

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

الأخ المتميز زوهير بارك الله فيك على هذا الكود الرائع جزيت خير الجزاء أخي الكريم شكيب عمار .. موضوع الشرح مرهق للغاية استغرق مني الشرح حوالي ساعة ونصف (لا تنسى أن تضغط على كلمة "أعجبني هذا") ولا تضغط على كلمة "تحديد كأفضل إجابة" إذ أن مشاركتي ليست بإجابة إنما هي شرح لما تفضل به الرائع زوهير Option Explicit 'يوضع الكود في حدث الفورم ليتم إضافة واستدعاء وتعديل البيانات 'البيانات في ورقة عمل باسم "ورقة 2" والصف الأول يحمل العناوين الآتية 'كود الموظف - الاسم واللقب - تاريخ الميلاد - الوظيفة 'يتم إنشاء مربع نص للكود وآخر للاسم وآخر لتاريخ الميلاد وآخر للوظيفة 'وزري أمر للاستدعاء والتعديل [ListBox1] ويوضع داخله مربع القائمة [Frame1] يتم إنشاء إطار 'بعنوان البحث والتعديل كما يتم إنشاء زر أمر باسم إضافة [CheckBox1] يتم إنشاء '--------------------------------------------------------------------------------------- Private Sub CheckBox1_Click() 'حيث أن لمربع الفحص قيمتان [CheckBox1] يقوم الكود بالعمل عند النقر على '[True] إذا كان المربع تم تحديده أي وضع علامة صح فإنه يحمل القيمة '[False] إذا كان المربع لم يتم تحديده أي أنه لا توجد علامة صح فإنه يحمل القيمة '--------------------------------------------------------------------------- '[True] فإذا كانت القيمة تساوي If CheckBox1.Value Then 'يظهر الإطار بما في داخله من أدوات Frame1.Visible = True '[False] وإذا كانت القيمة تساوي Else 'يختفي الإطار بما في داخله من أدوات Frame1.Visible = False End If End Sub Private Sub CommandButton1_Click() 'يتم تنفيذ الأسطر عند النقر على زر الإضافة '--------------------------------------- Dim iRow As Long, I As Long 'سطر لتنشيط أو تحديد ورقة العمل الهدف Sheets(2).Activate 'تعيين قيمة للمتغير ليساوي رقم آخر صف به بيانات في العمود الأول iRow = Range("A" & Rows.Count).End(xlUp).Row 'في آخر صف به بيانات يتم الإشارة إلى الصف التالي لأنه أول صف فارغ 'توضع قيمة مربع النص الأول في العمود الأول Range("A" & iRow + 1).Value = TextBox1.Value 'تتم الإزاحة إلى الخلية المجاورة بمقدار عمود واحد وتوضع قيمة مربع النص الثاني Range("A" & iRow + 1).Offset(0, 1).Value = TextBox2.Value 'تتم الإزاحة إلى الخلية المجاورة بمقدار عمودين وتوضع قيمة مربع النص الثالث 'يتم تنسيق مربع النص لتاريخ الميلاد لتظر بهذا التنسيق المذكور في السطر Range("A" & iRow + 1).Offset(0, 2).Value = Format(TextBox3, "yyyy/dd/mm") 'تتم الإزاحة إلى الخلية المجاورة بمقدار ثلاثة أعمدة وتوضع قيمة مربع النص الرابع Range("A" & iRow + 1).Offset(0, 3).Value = TextBox4.Value 'حلقة تكرارية لمسح مربعات النصوص الأربعة بعد ترحيل البيانات For I = 1 To 4 Controls("TextBox" & I).Value = "" Next I End Sub Private Sub CommandButton2_Click() 'يتم تنفيذ الأسطر عند النقر على زر الاستدعاء '----------------------------------------- 'الإعلان عن المتغيرات Dim Zouhir As Worksheet Dim V As Integer, LastRow As Integer Dim M As String Dim Q, F 'سطر لتنشيط أو تحديد ورقة العمل الهدف Sheets(2).Activate '[ListBox1] إظهار مربع القائمة ListBox1.Visible = True 'سطر لتجنب حدوث خطأ On Error Resume Next 'مسح البيانات داخل مربع القائمة ListBox1.Clear 'إذا كان مربع النص الأول فارغ يتم القفز إلى السطر الذي بدايته رقم 1 'أي إنهاء الإجراء الفرعي If TextBox1.Text = "" Then GoTo 1 'تعيين قيمة للمتغير ليساوي قيمة مربع النص الأول M = TextBox1.Text 'تعيين قيمة للمتغير ليساوي ورقة العمل الهدف Set Zouhir = Sheets(2) 'بدء التعامل مع ورقة العمل With Zouhir 'تعيين قيمة للمتغير ليساوي رقم آخر صف به بيانات في العمود الأول LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'تعيين المتغير ليساوي النطاق الذي يطابق البحث عن قيمة مربع النص Set Q = .Range("A2:A" & LastRow).Find(M) 'إذا تم إيجاد الكود الذي يطابق مربع النص If Not Q Is Nothing Then 'يتم تعيين قيمة للمتغير ليساوي عنوان الخلية التي طابقت عملية البحث F = Q.Address 'حلقة تكرارية تنفذ إلى أن تنتهي نتائج البحث عن القيمة الموجودة بمربع النص Do 'سطر يستخدم دالة البحث عن قيمة مربع النص داخل النطاق فإذا كانت النتيجة تساوي 1 If Application.WorksheetFunction.Search(M, Q, 0) = 1 Then 'يتم إضافة العناصر إلى مربع القائمة 'عبارة عن صفوف وأعمدة والصفوف تمثل الفهرس الذي يبدأ من صفر [ListBox1] مربع القائمة 'لم يتم تعيين قيمة له في الأسطر السابقة لذا فإنه يحمل القيمة صفر [V] المتغير المسمى 'تمثل الأرقام 1 و 2 و 3 و 4 أرقام الأعمدة في مربع القائمة ListBox1.AddItem Q.Value ListBox1.List(V, 1) = Q.Offset(0, 1).Value ListBox1.List(V, 2) = Q.Offset(0, 2).Value ListBox1.List(V, 3) = Q.Offset(0, 3).Value ListBox1.List(V, 4) = Q.Offset(0, 4).Value 'العمود الخامس في مربع القائمة وهو وهمي ليحمل عنوان النطاق الحالي المطابق للبحث ListBox1.List(V, 5) = Q.Address 'زيادة قيمة المتغير بمقدار واحد V = V + 1 End If 'مرة أخرى ليساوي هذه المرة نتيجة البحث التالية [Q] تعيين المتغير المسمى Set Q = .Range("A2:A" & LastRow).FindNext(Q) Loop While Not Q Is Nothing And Q.Address <> F End If End With 1 End Sub Private Sub CommandButton3_Click() 'يتم تنفيذ الأسطر عند النقر على زر التعديل '----------------------------------------- 'الإعلان عن المتغيرات Dim Zouh As String Dim MYSH As Worksheet Dim MSG As String Dim ANS As Integer Dim I As Long 'سطر لتنشيط أو تحديد ورقة العمل الهدف Sheets(2).Activate On Error Resume Next 'تعيين المتغير ليساوي السلسلة النصية بعد علامة يساوي MSG = "هل أنت متأكد؟" '[Yes - No] تعيين المتغير ليساوي قيمة النقر على أحد الاختيارين ANS = MsgBox(MSG, vbYesNo) 'إذا كانت الإجابة بنعم يتم تنفيذ الأسطر التالية If ANS = vbYes Then 'تعيين المتغير من النوع سلسلة نصية ليساوي عنوان الخلية في العمود الأول للبيان الذي تم النقر عليه Zouh = ListBox1.List(ListBox1.ListIndex, 5) 'تعيين المتغير ليساوي ورقة العمل الهدف Set MYSH = Sheets(2) 'بدء التعامل مع ورقة العمل With MYSH 'تحديد الخلية للمتغير المشار إليه .Application.Range(Zouh).Activate 'قيمة الخلية نفسها وهنا لا تتم عملية الإزاحة لأنها نقطة البداية وتساوي مربع النص الأول .Range(Zouh).Offset(0, 0).Value = TextBox1.Value 'تتم عملية الإزاحة بمقدار عمود واحد وتساوي مربع النص الثاني .Range(Zouh).Offset(0, 1).Value = TextBox2.Value 'تتم عملية الإزاحة بمقدار عمودين وتساوي مربع النص الثالث .Range(Zouh).Offset(0, 2).Value = TextBox3.Value 'تتم عملية الإزاحة بمقدار ثلاثة أعمدة وتساوي مربع النص الرابع .Range(Zouh).Offset(0, 3).Value = TextBox4.Value End With End If 'حلقة تكرارية لمسح مربعات النصوص الأربعة بعد ترحيل البيانات For I = 1 To 4 Me.Controls("TextBox" & I).Text = "" Next I 'إغلاق الفورم بشكل مؤقت Unload Me 'إظهار الفورم UserForm1.Show 'إخفاء مربع القائمة ListBox1.Visible = False End Sub Private Sub ListBox1_Click() '[ListBox1] يتم تنفيذ الإجراء في حالة النقر داخل '---------------------------------------------- 'في حالة حدوث خطأ يتم إنهاء الإجراء الفرعي On Error GoTo 1 Dim MYSH As Worksheet, Zouh As String 'تعيين المتغير من النوع سلسلة نصية ليساوي عنوان الخلية في العمود الأول للبيان الذي تم النقر عليه Zouh = ListBox1.List(ListBox1.ListIndex, 5) 'تعيين المتغير ليساوي ورقة العمل الهدف Set MYSH = Sheets(2) 'بدء التعامل مع ورقة العمل With MYSH 'تحديد الخلية للمتغير المشار إليه Application.Range(Zouh).Activate 'مربع النص الأول يساوي نطاق الخلية المشار إلى عنوانها TextBox1.Text = .Range(Zouh).Value 'مربع النص الثاني يساوي الخلية المجاورة بمقدار عمود واحد TextBox2.Text = .Range(Zouh).Offset(0, 1).Value 'مربع النص الثالث يساوي الخلية المجاورة بمقدار عمودين TextBox3.Text = .Range(Zouh).Offset(0, 2).Value 'مربع النص الرابع يساوي الخلية المجاورة بمقدار ثلاثة أعمدة TextBox4.Text = .Range(Zouh).Offset(0, 3).Value End With 1 End Sub Private Sub UserForm_Initialize() 'ينفذ هذا السطر عند تشغيل الفورم ويقوم بإخفاء الإطار بما في داخله من أدوات '------------------------------------------------------------------------- Frame1.Visible = False End Sub وزيادة في الخير أرفق لك الملف به الكود مشروح ربما لا تحب أن تقرأ الشرح في المنتدى وتقرأه من داخل محرر الأكواد لا تنسانا بدعوة بظهر الغيب تقبل الله منا ومنكم :gift2: Add Edit Call UserForm Zuhair.rar

أخي الكريم خالد الشاعر لقد قمت بالإعلان عن المتغير من النوع Long وهو للأرقام الصحيحة الطويلة وهذا خطأ لأنك في سطر ما أعلنت عن أن المتغير يساوي قيمة الخلية C10 والتي تحمل القيمة A فيجب إما الإعلان عنها كـ String أي سلسلة نصية أو تتركها بدون تحديد نوعها ليتم معاملتها كـ Variant

الأخ الكريم هشام كمال الأخ الغالي علاء رسلان الأخ الحبيب زيزو العجوز جربوا الدالة المعرفة التالية UDF Function يتم وضع الدالة في موديول جديد Public Function Wish(rngData As Range, rngWish As Range) Dim ArrData, ArrWish, ArrOut, ArrSwap Dim ColCount As Long, I As Long, J As Long, K As Long ArrData = rngData.Value ArrWish = rngWish.Value ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1) ColCount = UBound(ArrData, 2) ReDim ArrSwap(1 To 1, 1 To ColCount) For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, ColCount) > ArrData(I, ColCount) Then For J = 1 To ColCount ArrSwap(1, J) = ArrData(I, J) ArrData(I, J) = ArrData(K, J) ArrData(K, J) = ArrSwap(1, J) Next J End If Next K Next I For I = 1 To UBound(ArrData, 1) For J = 1 To (ColCount - 1) If ArrOut(I, 1) = "" Then For K = 1 To UBound(ArrWish, 1) If ArrData(I, J) = ArrWish(K, 1) Then If ArrWish(K, 2) > 0 Then ArrOut(I, 1) = ArrWish(K, 1) ArrWish(K, 2) = ArrWish(K, 2) - 1 End If End If Next K End If Next J Next I For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, 1) < ArrData(I, 1) Then ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1) ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1) ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2) End If Next K Next I Wish = ArrOut End Function لاستخدام الدالة في ورقة العمل يتم تحديد النطاق الذي ترغب في ظهور النتائج به ... النطاق K8:K27 بعد تحديد النطاق روح لشريط المعادلات وضع المعادلة التالية =Wish(D8:J27,M12:N15) حيث يمثل الجزء الأول نطاق البيانات بالكامل D8:J27 ويمثل الجزء الثاني نطاق الحد الأقصى المسموح به M12:N15 ثم أخيراً بعد وضع المعادلة في شريط المعادلات تضغط على Ctrl + Shift + Enter ... هنا لا يتم كتابة المعادلة ثم سحبها بل يتم تحديد النطاق بالكامل ثم وضع المعادلة ثم تضغط على Ctrl + Shift + Enter أرجو أن يفي بالغرض .. جرب الملف وأعملنا بالنتائج إذا أعجبك الحل لا تنسى أن تحدد أفضل إجابة ، وأن تضغط على كلمة "أعجبني هذا" إذا أعجبك الحل تقبلوا تحياتي Pupils Distribution According To Marks & Wishes.rar

أخي الكريم خالد أنصحك عند طرح موضوع أن يتم تنسيق الملف بشكل مناسب وتضع بعض البيانات لتجربة الأكواد عليها عموماً جرب الكود بهذا الشكل عله يكون المطلوب Sub TarhilRaseb2() Dim I As Long, X As Long Dim WS As Worksheet, SH As Worksheet Dim RngA Dim RngColA As Long, RngColB As Long, RngColC As Long, RngColD As Long Dim LR As Long Application.ScreenUpdating = False Rows("13:112").EntireRow.Hidden = False Set WS = Sheets("Main"): Set SH = Sheets("مواد") RngA = SH.Range("C10").Value RngColA = SH.Range("O3").Value: RngColB = SH.Range("P3").Value: RngColC = SH.Range("Q3").Value: RngColD = SH.Range("R3").Value X = 13 SH.Range("A13:D112").ClearContents With WS For I = 14 To Worksheets("مواد").Range("P6").Value If WS.Cells(I, 3).Value = RngA Then '.Cells(I, RngColA) = RngA Then SH.Cells(X, 8).Value = SH.Cells(X, 1).Row - 12 SH.Cells(X, 6).Value = WS.Cells(I, 2).Value SH.Cells(X, 7).Value = WS.Cells(I, 3).Value 'SH.Cells(X, 4).Value = WS.Cells(I, 12).Value SH.Cells(X, 2).Value = WS.Cells(I, RngColA).Value SH.Cells(X, 3).Value = WS.Cells(I, RngColB).Value SH.Cells(X, 4).Value = WS.Cells(I, RngColC).Value SH.Cells(X, 1).Value = WS.Cells(I, RngColD).Value X = X + 1 End If Next I End With LR = Range("A13:A112").End(xlUp).Row Range("A13:A112").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True End Sub

الأخ الكريم هشام راجع المشاركة رقم 14 ...

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

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

بارك الله فيك أخي الكريم أحمد يرجى التوضيح ..يعني ايه بالاسم والمجموع

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

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

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

ببساطة أخي أحمد اضغط Alt + F11 من لوحة المفاتيح للدخول للمحرر هتلاقي نافذة اسمها نافذة المشروع Project window هتلاقي كلمة UserForm1 اعمل عليها كليك يمين ثم View Code

بارك الله فيك أخي الكريم احمد السيد سليمان جزيت خيراً على الحل الجميل والرائع أخي الحبيب جلال الجمال كل عام وأنت بخير عساكم من عوادة إليك الملف التالي إثراءً للحلل Calculate Series Of Dates.rar

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