كود او دالة انشاء ارقام عشوائية بشرط عدم التكرار

[ALHAWI]

السلام عليكم اخوتي الاعزاء

عايز منكم كود او دالة لانشاء ارقام عشوائية

زي عمل الدالة RANDBETWEEN

بس عايز الرقم الي ظهر ما يتكرر

وتقبلوا تحياتي لكم اخوتي

المصنف1.xlsx

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

جرب هذا الملف

الكود

Option Explicit
Sub Ashwaii()
Dim my_rg As Range
Dim My_min%, My_max%: My_min = [c1]: My_max = [d1]
Dim lra%: lra = Cells(Rows.Count, 1).End(3).Row
If lra < 2 Then lra = 2
Range("a2:a" & lra).ClearContents
Dim Nb%: Nb = My_max - My_min + 1
Range("a2").FormulaArray = "=IF(ROWS($A$1:A1)>$D$1-$C$1+1,"""",LARGE((COUNTIF($A$1:A1,ROW(INDIRECT($C$1&"":""&$D$1)))=0)*ROW(INDIRECT($C$1&"":""&$D$1)),RANDBETWEEN(1,SUM(--(COUNTIF($A$1:A1,ROW(INDIRECT($C$1&"":""&$D$1)))=0)))))"
Range("a2").AutoFill Destination:=Range("a2:a" & Nb + 1)
Range("a2:a" & Nb + 1).Value = Range("a2:a" & Nb + 1).Value
End Sub

الملف مرفق

 

 

Fix_rand.xlsm

[ALHAWI]

استاذي العزيز شكرا على المتابعة والرد

ولكن عند انشاء العدد المطلوب بفرض 1000 رقم يكون هناك بطء في المعالجه والحساب

وانا عيز نفس الملف المرسل من قبلي بالزبط  في عملية الحساب بيكون سريع

لان انا بحاجة لانشاء ارقام حتى 4000 رقم

والكود بتاعك بياخذ وقت كبير

اتمنى منك الرد

ومشكـــور جداً استاذي العزيز سليم

[إيهاب عبد الحميد]

أخي الكريم
اليك ملف به بعض الدول للاختيار العشوائي أرجو أن يفيدك

الاختيار العشوائي كاملاً.xlsx

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

تم التعديل على الكود ليعمل بسرعة اكبر بكثير (9000 رقم في 2.3 ثانية)

الكود

Option Explicit
'Excel VBA to generate random number
'Created by Salim on 21/3/2018
Sub Generate_Uniq_Random()
If ActiveSheet.Name <> "Salim" Then GoTo Exit_sub
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
Dim myStart As Long
Dim myEnd As Long
Dim x As Byte
Dim i As Long
Dim lr_B: lr_B = Cells(Rows.Count, 2).End(3).Row
 If lr_B < 2 Then lr_B = 2
 Range("b2:C" & lr_B).ClearContents
Dim a()
myStart = [G2]
myEnd = [H2]
ReDim a(0 To myEnd - myStart)
 For x = 1 To 2
 If x = 1 Then
  With CreateObject("System.Collections.SortedList")
    Randomize
    For i = myStart To myEnd
      .Item(Rnd) = i
      Next i
      For i = 0 To .Count - 1
      a(i) = .GetByIndex(i)
    Next
  End With
  Range("b2").Resize(UBound(a) + 1).Value = Application.Transpose(a)
Else
With CreateObject("System.Collections.SortedList")
    Randomize
    For i = myStart To myEnd
      .Item(Rnd) = i
      Next i
      For i = 0 To .Count - 1
      a(i) = .GetByIndex(i)
    Next
  End With
  Range("c2").Resize(UBound(a) + 1).Value = Application.Transpose(a)
End If
Next
Exit_sub:
With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

الملف مرفق

 

 

Fix_randbetween.xlsm

[Ali Mohamed Ali]

بارك الله فيك أستاذ سليم وجزاك الله خيرا وجعله فى ميزان حسناتك

فعلا كود فى غاية الفن والإتقان والسرعة وايضا جلب الأرقام بدون تكرار

ابداع ودائما الى الأمام والتفوق -وجعلك الله زخرا لمن يحتاج المساعدة منك

أخى الكريم وفقك الله لما يحب ويرضى

[ALHAWI]

مشكووور استاذنا العزيز ووفقك الله وحفظك

[مصطفى محمود مصطفى]

رائع استاذ سليم دائما مبدع

وفقكم الله وحفظكم

هل يمكن التعديل على الكود بان يعمل على عمود واحد

انشاء ارقام عشوائية بدون تكرار  لكن في عمود واحد ؟ وكيف اتحكم بمدى العمود ؟

تحياكم لكم ووافر احترامي

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

هذا الماكرو

Option Explicit
Sub rand_num_generator()
Dim i%
Dim myStart%: myStart = Application.Min([c2], [d2])
Dim myEnd%: myEnd = Application.Max([c2], [d2])
Dim a()
Range("a2").CurrentRegion.ClearContents
ReDim a(myEnd - myStart)

 With CreateObject("System.Collections.SortedList")
      For i = myStart To myEnd
       .Item(Rnd) = i
      Next i
      i = 0
      Do Until i > .Count - 1
       a(i) = .GetByIndex(i)
       i = i + 1
     Loop
  End With
  Range("a2").Resize(UBound(a) + 1).Value = Application.Transpose(a)
  Erase a
End Sub

الملف مرفق

 

Rand_Genarator.xlsm

[مصطفى محمود مصطفى]

وفقكم الله وحفظكم من كل سوء

استاذ سليم المبدع . كود اكثر من رائع

جعله الله في ميزان حسناتكم

 لكم وافر احترامي وتقديري

[مصطفى محمود مصطفى]

الاستاذ سليم وفقكم الله

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

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

واليكم ملف به الكود وارجو ملاحظة التغيير الذي اجريته لربما منه الخطا

لكم وافر احترامي

المصنف1.xlsm

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

التعديل يتم باستبدال سطر واحد من الكود (ما بين النجوم) ليبدو هكذا

Sub rand_num_generator()
Dim i%
Dim myStart%: myStart = Application.Min([N3], [O3])
Dim myEnd%: myEnd = Application.Max([N3], [O3])
Dim a()
'****************************************
Range("A3").CurrentRegion.Columns(1) _
.Offset(1).ClearContents
'****************************************
ReDim a(myEnd - myStart)

 With CreateObject("System.Collections.SortedList")
      For i = myStart To myEnd
       .Item(Rnd) = i
      Next i
      i = 0
      Do Until i > .Count - 1
       a(i) = .GetByIndex(i)
       i = i + 1
     Loop
  End With
  Range("A3").Resize(UBound(a) + 1).Value = Application.Transpose(a)
  Erase a
End Sub

الكود الثاني

'==================================
Range("F3").CurrentRegion.Columns(1) _
.Offset(1).ClearContents
'================================

 

[مصطفى محمود مصطفى]

الاستاذ سليم حفظكم الله ورزقكم من فضله خيرا كثيرا

احسنتم تعديل ممتاز جعل الله اعمالكم في ميزان حسناتكم

لكم ودي واحترامي