مساعدة : اريد حذف اي رقم يتك تكرار

[محمود الحربي]

السلام عليكم ورحمة الله وبركاته

 

ارجو من الاخوان في المنتدى الكريم المساعدة في عدم تكرار الأرقام

 

الملف مرفق لكم في التفاصيل

 

 

شاكر ومقدر لكم

المصنف1.rar

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

جرب هذا الماكرو

الملف مرفق

Option Explicit

Sub Tirage_Aleatoire_N_Valeurs_Dans_Liste()
   Dim SL, ar, i, NB, Lr, k
   With Application
   .ScreenUpdating = False
   .Calculation = xlCalculationManual
   End With
  NB = 15 ' '   العدد المطلوب ناقص 1
 Lr = 34
For k = 1 To 11 Step 2
    ar = Range("A2: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)) Then SL.Add Rnd, ar(i, 1)
   Next i
        With ActiveSheet
         For i = 0 To Application.Min(SL.Count - 1, NB) - 1
            .Cells(i + 39, k).Value = SL.GetByIndex(i)
         Next
   End With
  Next
    With Application
   .ScreenUpdating = True
   .Calculation = xlCalculationAutomatic
   End With
End Sub

 

المصنف1 Salim.rar

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

بارك الله فيك أخي الغالي سليم وجزيت خيراً على هذا الكود المميز والرائع

جربت الكود ووجدت النتائج قد تكون غير دقيقة ويمكن حدوث تكرار .. لذا أضفت شرط في سطر الشرط وإليك التعديل التالي 

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

 

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

6 ساعات مضت, ياسر خليل أبو البراء said:

بارك الله فيك أخي الغالي سليم وجزيت خيراً على هذا الكود المميز والرائع

جربت الكود ووجدت النتائج قد تكون غير دقيقة ويمكن حدوث تكرار .. لذا أضفت شرط في سطر الشرط وإليك التعديل التالي 

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

 

باركالله بك اخي ياسر 

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

Option Explicit
Option Base 1
Sub Rand()

    Dim r, c, i, k As Integer
    For k = 1 To 11 Step 2
     Dim g(34)
    Do
      c = Application.RandBetween(1, 34)
        If Not g(c) Then
            r = r + 1
            Cells(i + 39, k) = c: Cells(i + 39, k + 1) = Range("b" & c)
            i = i + 1
            g(c) = True
        End If
    Loop Until r = 14
    r = 0: i = 0
    Erase g
    Next
End Sub

 

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

جزاك الله خيراً أخي الحبيب سليم

الكود الثاني أفضل وأسرع .. بارك الله فيك

وكل عام وأنت بخير

[محمود الحربي]

لا تعمل الرجاء ارفاق ملف

 

رحم الله والدينكم

[محمود الحربي]

يوجد تكرار

 

الفكرة العامة للملف حتي توضح الصورة

 

انا اريد اختار رئيس لكل مجموعة من ضمن المجموعة ويتم التوزيع عشوائي

للبقية على المجموعات تزيد المجموعات وتنقص بشرط عدم تكرار الأشخاص

وجميع الاكواد هذا تكرر الافراد في كل مجموعة

1212.rar

[محمود الحربي]

كيف احط شرط لهذا الدالة عدم تكرار من الارقام

RANDBETWEEN($G$1;$G$7)=

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

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

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

[محمود الحربي]

هذا مثال توضيحي للشكل النهائي الى احتاجة

 

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

الشكل النهائي شرح.rar

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

العدد الإجمالي 34 في المثال المرفق ولديك 4 مجموعات كل مجموعة مكونة من 5  .. إذاً العدد سيكون 4 * 5 = 20 ، فما مصير الباقي من العدد الإجمالي 34-20 = 14

المفترض أن تكون الأسماء مختلفة ولا يوجد تشابه .. لاحظ وجود الاسم أحمد في الخلية B2 و B35 أم أن المثال فقط للتوضيح أم هل سيكون هناك تشابه في الاسماء؟

[محمود الحربي]

الأسماء لا توجد تشابه بها نهائياً

 

بالنسبة للاعداد في يتم توزيعها على المجموعات كاملة بدون نقص 

 

الاسماء مثال فقط لان ممكن العدد يصبح اكثر من 60 أو 80 

 

رحم الله وأمك وأبوك 

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

أعتذر عن كثرة الأسئلة أحاول الإمساك بكافة الخيوط لأن الموضوع معقد ومتشعب

هل عدد المجموعات ثابت أم أنه متغير ..؟

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

[محمود الحربي]

عدد المجموعات متغير 

 

عدد الأسر ليس شرط ارقام متساوية

 

 

يعني ذلك عدد الأسر والافراد لكل أسرة متغير

مع تغير المجموعات بزيادة ونقص 

[محمود الحربي]

اقتباس

هل عدد المجموعات ثابت أم أنه متغير ..؟

لا عدد المجموعات متغير يزيد وينقص يحسب

 

هل رؤساء المجموعات من الاسر ؟

 

نعم يتم اختيار رؤساء المجموعات من الاسر اختيار يدوي وليس عشوائي .

هل العدد الإجمالي للأسر تحت الرئيس متساوية ؟

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