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

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

الخطأ يدل على أنك تستخدم النسخة الفرنسية لذا يجب تغيير دالة IF إلى Somme على ما أعتقد

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

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

قم بضغط الملف ثم ابحث عن كلمة "رفع الملف" وقم برفعه للإطلاع عليه ومحاولة رؤية المشكلة من زاوية أقرب

العدد الإجمالي 34 في المثال المرفق ولديك 4 مجموعات كل مجموعة مكونة من 5 .. إذاً العدد سيكون 4 * 5 = 20 ، فما مصير الباقي من العدد الإجمالي 34-20 = 14 المفترض أن تكون الأسماء مختلفة ولا يوجد تشابه .. لاحظ وجود الاسم أحمد في الخلية B2 و B35 أم أن المثال فقط للتوضيح أم هل سيكون هناك تشابه في الاسماء؟

وعليكم السلام استخدم معادلة IF بشكل بسيط لتحقيق المطلوب =IF(A5-B5=0,"//////",A5-B5)

عناوين الأعمدة مختلفة في الملفات رقم 1 و 2 .. ما هي الأعمدة المراد ترحيلها وإلى أين تريد ترحيلها؟ لو أرفقت صورة توضيحية يكون أفضل

تأكد من عدم وجود مسافات زائدة في أحد المدخلات .. لربما كان السبب في مشكلتك والأفضل أن ترفق ملف بالمشكلة لتتضح الصورة أكثر بالنسبة لعدم ظهور جزء في الطباعة ادخل على التبويب View ثم Page Break Preview وقم بسحب السطر الأزرق لتحدد نهاية الجزء المطلوب طباعته

ما هو عدد أفراد كل مجموعة وكيف ستتم عملية التوزيع ؟ أقصد كيف يتم تحديد عدد أفراد كل مجموعة .. وما هو مقصدك بقولك : كل مجموعة تزيد أو تنقص ..؟ هل معنى ذلك أن عدد كل مجموعة غير ثابت ...؟ أعتقد الموضوع يحتاج لمزيد من التفاصيل مع إرفاق نموذج مصغر به بعض النتائج المتوقعة .. لتشرح على أساسها

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

قم بالإطلاع على الكود وغير أسماء أوراق العمل في أسطر الكود ليعمل بشكل صحيح

الكود يقوم بمسح الجداول للنتائج أولاً ويعمل من جديد مع كل مرة يتم تنفيذه نعم يمكن عمل زر أمر وربط الماكرو به للمزيد حول الأساسيات للتعامل مع محرر الأكواد قم بمشاهدة الفيديو التالي

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

اطلع على المرفق التالي عله يفي بالغرض (تم استخدام دالة معرفة مستحدثة للأستاذ والأخ الحبيب حسام عيسى) N.rar

إذا لم يتدخل أحد الأخوة سأحاول في موضوعك غداّ إن شاء الله

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

ضع جملة On Error Resume Next في بداية الكود لتلافي الخطأ ... أو يمكن معرفة سبب الخطأ ومعالجته برمجياً .. الخيار لك

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

اطلعت على الكود ويبدو أن الكود لملف آخر حيث يوجد تضارب كبير .. عموماً الأفضل أن يكون الطلب واضح في عملية الترحيل .. ما هي ورقة البيانات التي يتم جلب البيانات منها وإلى أي ورقة تريد الترحيل وما هي الأعمدة المطلوبة في كل ورقة الكود المرفق في الملف بسيط ويمكنك التعديل عليه بسهولة ليتوافق مع مطلوبك .. الموضوع فقط يحتاج لمزيد من التفصيل والتوضيح ويوجد ملف مشابه لطلبك حيث يمكن ترحيل أعمدة محددة بأسلوب المصفوفات Extract Pass Using Arrays YasserKhalil.rar

وعليكم السلام جرب الكود التالي وإذا لم يكن المطلوب ارفق ملف لتتضح الصورة Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range If Not Intersect(Target, Range("F7:F500")) Is Nothing Then If Target.Value = Target.Offset(0, -2).Value * Target.Offset(0, -4).Value Then Application.Speech.Speak "Correct Answer" Else Application.Speech.Speak "Wrong Answer Try Again" End If End If End Sub

السلام عليكم جرب الكود التالي لعله يفي بالغرض إن شاء الله Sub Test() Dim arr As Variant Dim temp1 As Variant Dim temp2 As Variant Dim i As Long Dim j As Long Dim k As Long Dim l As Long arr = Sheet1.Range("A3").CurrentRegion.Value ReDim temp1(1 To UBound(arr, 1), 1 To UBound(arr, 2)) ReDim temp2(1 To UBound(arr, 1), 1 To UBound(arr, 2)) For i = 2 To UBound(arr, 1) If arr(i, 2) = "ABC" Then k = k + 1 For j = 1 To UBound(arr, 2) temp1(k, j) = arr(i, j) Next j End If If arr(i, 2) = "DEF" Then l = l + 1 For j = 1 To UBound(arr, 2) temp2(l, j) = arr(i, j) Next j End If Next i With Sheets("ABC") .Range("A4:I25").ClearContents .Range("A4").Resize(k, UBound(arr, 2)).Value = temp1 End With With Sheets("DEF") .Range("A4:I25").ClearContents .Range("A4").Resize(l, UBound(arr, 2)).Value = temp2 End With '======================================================= k = 0: l = 0: Erase arr: Erase temp1: Erase temp2 arr = Sheet1.Range("M3").CurrentRegion.Value ReDim temp1(1 To UBound(arr, 1), 1 To UBound(arr, 2)) ReDim temp2(1 To UBound(arr, 1), 1 To UBound(arr, 2)) For i = 2 To UBound(arr, 1) If arr(i, 2) = "ABC" Then k = k + 1 For j = 1 To UBound(arr, 2) temp1(k, j) = arr(i, j) Next j End If If arr(i, 2) = "DEF" Then l = l + 1 For j = 1 To UBound(arr, 2) temp2(l, j) = arr(i, j) Next j End If Next i With Sheets("ABC") .Range("M4:U25").ClearContents .Range("M4").Resize(k, UBound(arr, 2)).Value = temp1 End With With Sheets("DEF") .Range("M4:U25").ClearContents .Range("M4").Resize(l, UBound(arr, 2)).Value = temp2 End With End Sub

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

الموضوع مكرر يرجى التأكيد لحذف هذا الموضوع والإبقاء على موضوع واحد فقط تقبل تحياتي

بارك الله فيك أخي الغالي سليم وجزيت خيراً على هذا الكود المميز والرائع جربت الكود ووجدت النتائج قد تكون غير دقيقة ويمكن حدوث تكرار .. لذا أضفت شرط في سطر الشرط وإليك التعديل التالي Sub RandomListsSALIM() Dim SL As Object Dim ar As Variant Dim Lr As Long Dim k As Long Dim i As Long Dim nb As Long With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With nb = 16 'Required Plus One +1 Lr = 34 For k = 1 To 11 Step 2 ar = Range("A1:A" & Lr) If Not IsNumeric(nb) Or nb > Lr Or nb < 0 Then nb = Lr - 1 Set SL = CreateObject("System.Collections.SortedList") Randomize For i = 1 To nb If Not SL.containsvalue(ar(i, 1)) And Cells(38, k) <> ar(i, 1) Then SL.Add Rnd, ar(i, 1) Next i For i = 0 To nb - 3 Cells(i + 39, k).Value = SL.GetByIndex(i) Next i Next k With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub