ALHAWI قام بنشر مارس 20, 2018 مشاركة قام بنشر مارس 20, 2018 السلام عليكم اخوتي الاعزاء عايز منكم كود او دالة لانشاء ارقام عشوائية زي عمل الدالة RANDBETWEEN بس عايز الرقم الي ظهر ما يتكرر وتقبلوا تحياتي لكم اخوتي المصنف1.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مارس 21, 2018 مشاركة قام بنشر مارس 21, 2018 جرب هذا الملف الكود 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 رابط هذا التعليق شارك More sharing options...
ALHAWI قام بنشر مارس 21, 2018 الكاتب مشاركة قام بنشر مارس 21, 2018 استاذي العزيز شكرا على المتابعة والرد ولكن عند انشاء العدد المطلوب بفرض 1000 رقم يكون هناك بطء في المعالجه والحساب وانا عيز نفس الملف المرسل من قبلي بالزبط في عملية الحساب بيكون سريع لان انا بحاجة لانشاء ارقام حتى 4000 رقم والكود بتاعك بياخذ وقت كبير اتمنى منك الرد ومشكـــور جداً استاذي العزيز سليم رابط هذا التعليق شارك More sharing options...
إيهاب عبد الحميد قام بنشر مارس 21, 2018 مشاركة قام بنشر مارس 21, 2018 أخي الكريم اليك ملف به بعض الدول للاختيار العشوائي أرجو أن يفيدك الاختيار العشوائي كاملاً.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مارس 21, 2018 مشاركة قام بنشر مارس 21, 2018 تم التعديل على الكود ليعمل بسرعة اكبر بكثير (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 3 رابط هذا التعليق شارك More sharing options...
Ali Mohamed Ali قام بنشر مارس 21, 2018 مشاركة قام بنشر مارس 21, 2018 بارك الله فيك أستاذ سليم وجزاك الله خيرا وجعله فى ميزان حسناتك فعلا كود فى غاية الفن والإتقان والسرعة وايضا جلب الأرقام بدون تكرار ابداع ودائما الى الأمام والتفوق -وجعلك الله زخرا لمن يحتاج المساعدة منك أخى الكريم وفقك الله لما يحب ويرضى 2 رابط هذا التعليق شارك More sharing options...
ALHAWI قام بنشر مارس 27, 2018 الكاتب مشاركة قام بنشر مارس 27, 2018 مشكووور استاذنا العزيز ووفقك الله وحفظك 1 رابط هذا التعليق شارك More sharing options...
مصطفى محمود مصطفى قام بنشر ديسمبر 17, 2018 مشاركة قام بنشر ديسمبر 17, 2018 رائع استاذ سليم دائما مبدع وفقكم الله وحفظكم هل يمكن التعديل على الكود بان يعمل على عمود واحد انشاء ارقام عشوائية بدون تكرار لكن في عمود واحد ؟ وكيف اتحكم بمدى العمود ؟ تحياكم لكم ووافر احترامي رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 17, 2018 مشاركة قام بنشر ديسمبر 17, 2018 هذا الماكرو 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 رابط هذا التعليق شارك More sharing options...
مصطفى محمود مصطفى قام بنشر ديسمبر 17, 2018 مشاركة قام بنشر ديسمبر 17, 2018 وفقكم الله وحفظكم من كل سوء استاذ سليم المبدع . كود اكثر من رائع جعله الله في ميزان حسناتكم لكم وافر احترامي وتقديري 1 رابط هذا التعليق شارك More sharing options...
مصطفى محمود مصطفى قام بنشر ديسمبر 17, 2018 مشاركة قام بنشر ديسمبر 17, 2018 الاستاذ سليم وفقكم الله عند نقل الكود ال الملف قام بمسح الصفوف التي بجانب عمود توليد الارقام العشوائية هل يمكن تعديل على الكود بعدم حذف البيانات التي بجانب اعمدة التوليد العشوائي للارقام وانما فقط بالعمود الذي به توليد الارقام واليكم ملف به الكود وارجو ملاحظة التغيير الذي اجريته لربما منه الخطا لكم وافر احترامي المصنف1.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 17, 2018 مشاركة قام بنشر ديسمبر 17, 2018 التعديل يتم باستبدال سطر واحد من الكود (ما بين النجوم) ليبدو هكذا 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 '================================ رابط هذا التعليق شارك More sharing options...
مصطفى محمود مصطفى قام بنشر ديسمبر 18, 2018 مشاركة قام بنشر ديسمبر 18, 2018 الاستاذ سليم حفظكم الله ورزقكم من فضله خيرا كثيرا احسنتم تعديل ممتاز جعل الله اعمالكم في ميزان حسناتكم لكم ودي واحترامي 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان