اذهب الي المحتوي
أوفيسنا

أرقام عشوائية

دغيدى

بواسطه دغيدى
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

دغيدى

دغيدى

قام بنشر
قام بنشر (معدل)

السادة الأفاضل /

سلام الله عليكم

الملف المرفق هو لأحد الأخوة الزملاء"أكرمه الله "

لإدراج أرقام عشوائية غير مكررة

برجاء التعديل على الكود بحيث لا يمسح سوى العمود المدرج به الأرقام فقط ..

لأنه حاليا يمسح الصفحة كاملة..

ولكم منى جزيل الشكر

أرقام عشوائية.rar

تم تعديل بواسطه دغيدى
رابط هذا التعليق
شارك
عبدالله المجرب

عبدالله المجرب

قام بنشر
قام بنشر

برجاء التعديل على الكود بحيث لا يمسح سوى العمود المدرج به الأرقام فقط ..

لأنه حاليا يمسح الصفحة كاملة..

ولكم منى جزيل الشكر

الاستاذ الفاضل جمال (عمدتنا)

سيصبح الكود هكذا


    Sub Rnd_N_REP()

    Dim myrange As Range, rr, cc, pp As Integer

    rr = [B2]: cc = [B1]

    pp = rr * cc + 1

    Range("C3").SpecialCells (xlCellTypeLastCell)


    Set myrange = Range("C3", [c1000])

    myrange.ClearContents

   ' myrange.Interior.ColorIndex = xlNone


    Set myrange = Range("C3", [c3].Offset(rr - 1, cc - 1))


    'myrange.Interior.ColorIndex = 6

    Randomize

    For i = 0 To pp - 2

    rw = i Mod rr + 3

    If rr = cc Then cl = Int(i / cc) + 3 Else cl = i Mod cc + 3

10	    x = Int(Rnd * pp)

	    For Each ce In myrange

		    If ce = x Or x = 0 Then GoTo 10

	    Next ce


    Cells(rw, cl).Value = x

    Next i

    [c3].Select

    End Sub

رابط هذا التعليق
شارك
دغيدى

دغيدى

قام بنشر
  • الكاتب
قام بنشر

أخى الفاضل / أبو أحمد

سلام الله عليكم

برجاء تعديل الكود على أن تكون الأرقام العشوائية اعتبارا من D3

وتفضلوا بكل الحب والتقدير

رابط هذا التعليق
شارك
دغيدى

دغيدى

قام بنشر
  • الكاتب
قام بنشر 


Sub Rnd_N_REP()

    Dim myrange As Range, rr, cc, pp As Integer

    rr = [B2]: cc = [B1]

    pp = rr * cc + 1

    Range("d3").SpecialCells (xlCellTypeLastCell)


    Set myrange = Range("d3", [d1000])

    myrange.ClearContents

   ' myrange.Interior.ColorIndex = xlNone


    Set myrange = Range("d3", [d3].Offset(rr - 1, cc - 1))


    'myrange.Interior.ColorIndex = 6

    Randomize

    For i = 0 To pp - 2

    rw = i Mod rr + 3

    If rr = cc Then cl = Int(i / cc) + 3 Else cl = i Mod cc + 4

10		  x = Int(Rnd * pp)

		    For Each ce In myrange

				    If ce = x Or x = 0 Then GoTo 10

		    Next ce


    Cells(rw, cl).Value = x

    Next i

    [d3].Select

    End Sub

الأخوة الأفاضل /

أشكركم

لقد توصلت إلى الحل

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

السلام عليكم

وهذا برضه كود يقوم بعمل ارقام عشوائية بصندوق حوار للبداية والنهاية


Sub Ashwai()

Dim i As Integer, JX As Integer

Dim a() As Long

Dim ET_A As Boolean

Dim XXX As Long, EX As Long, NU_A As Long

On Error Resume Next

Range(Cells(4, 4), Cells(Rows.Count, 4)).ClearContents

XXX = Application.InputBox(prompt:="ادخل اول الارقام العشوائية" _

		, Title:="تأليف أرقام عشوائية", Default:=1, Type:=1)

EX = Application.InputBox(prompt:="ادخل الارقام النهائية العشوائية" _

		, Title:="تأليف أرقام عشوائية", Default:=100, Type:=1)

If EX = 0 Then Exit Sub

If EX > 15000 Then EX = 15000

If EX > EX - XXX + 1 Then

MsgBox "لايمكن تأليف سلسلة رقمية بداية اكبر من النهاية " _

& "ابداء برقم اصغر"

Exit Sub

End If

ReDim a(EX)

Randomize

a(1) = Int((EX - XXX + 1) * Rnd + XXX)

For i = 2 To EX

Do

NU_A = Int((EX - XXX + 1) * Rnd + XXX)

ET_A = False

For JX = 1 To i - 1

If NU_A = a(JX) Then ET_A = True: Exit For

Next JX

Loop While ET_A

a(i) = NU_A

Next i

For i = 1 To EX

Cells(i + 3, 4) = a(i)

Next i

End Sub

وهذا المرفق

AS_A.rar

رابط هذا التعليق
شارك
عبدالله باقشير

عبدالله باقشير

قام بنشر
قام بنشر

السلام عليكم

عند اختيار فرق الارقام 7

يكون هناك فرق فى التسلسل

فهل ممكن معالجة هذه المشكلة

شاهد المرفق

وتاكد من النتائج

الرقم السري2 خبور.rar

رابط هذا التعليق
شارك
خالد الشاعر

خالد الشاعر

قام بنشر
قام بنشر

تسلم ايدك استاذى خبور خير

منكم نتعلم دائماً

لى طلب اخير لو سمحت لى

فى خانة رقم الجلوس من الى

اذا كان عدد الطلبة 57 و الفرق بين الارقام 6 يكرر رقم الجلوس الاخير و السرى

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

و جزاكم الله خيراً

رابط هذا التعليق
شارك
saffaa

saffaa

قام بنشر
قام بنشر

تسلم ايدك استاذى خبور خير

يكرر رقم الجلوس الاخير و السرى

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

و جزاكم الله خيراً

ماذا تقصد اخي هل تريد ان يكون رقم الجلوس نفس رقم السري

في المجموعه الاخيره

اذا كان هذا قصدك وارجو ان لايكون كذلك

سيكون تصرف خاطئ كيف يكون رقم الجلوس نفسه رقم السري

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

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

رابط هذا التعليق
شارك
خالد الشاعر

خالد الشاعر

قام بنشر
قام بنشر

استاذ saffaa

جرب اذا كان عدد الطلبة 57 و الفرق بين الارقام 6 يكرر رقم الجلوس الاخير و السرى

سوف تلاحظ الرقم الاخير مثال 560 يكون مرتين من الى

هذا ما اقصد

رابط هذا التعليق
شارك
عبدالله باقشير

عبدالله باقشير

قام بنشر
قام بنشر

السلام عليكم

جمعة مباركة

استبدل الجزئية هذه


If ib Then

    iSeat = MyNSeat + (Contgrob * MyStp)

    iSry = Sry + (Contgrob * MyStp)

    kh_Add_Num iRow + Contgrob, St - 1

End If
بهذه الجزئية 

If ib Then

    iSeat = MyNSeat + (Contgrob * MyStp)

    iSry = Sry + (Contgrob * MyStp)

    ii = iRow + Contgrob

    kh_Add_Num ii, St - 1

    If St = 1 Then Union(Range("B" & ii), Range("D" & ii)).ClearContents

End If

رابط هذا التعليق
شارك
خالد الشاعر

خالد الشاعر

قام بنشر
قام بنشر (معدل)

تسلم ايدك استاذى خبور خير

كالعادة عبقرى فى كل شى

طلب اخير لاحظت اذا تم تنفيذ الماكرو مرة اخرى

يتم تغير الارقام فهل ممكن نجعل هذه الخاصية اختيارية بى تشك بوكس

اذا رغبت فى تغير الارقام

تسلم ايدك و جزاك الله خيراً

تم تعديل بواسطه khhanna
رابط هذا التعليق
شارك
خالد الشاعر

خالد الشاعر

قام بنشر
قام بنشر (معدل)

استاذ saffaa

اسف لم اقصد قفل الملف عن احد

لكنى كنت اجرب الفرز مع الحماية و نسيت فتح الملف

و انا تعلمت الكثير من هذا الموقع العظيم و من الاستاذ الكبير خبور

و الزاير شغالة كويس بس علم فى زر تشغيل

الملف مرفق مفتوح و اعتذر مرة اخرى

و شكراً

السري خبور.rar

تم تعديل بواسطه اا عبدالله المجرب اا
رابط هذا التعليق
شارك
عبدالله باقشير

عبدالله باقشير

قام بنشر
قام بنشر

السلام عليكم

تم اعادة ترتيب الكود ليظهر الخلايا بشكل واضح

ليتم التغيير فيه حسب الطلب


Option Explicit


Sub kh_Rnd_Num()

Dim ib As Boolean

Dim Sry, iSry

Dim MyAr$, MySr$, MyNum$

Dim MyCon%, MyStp%, iSp%, NRnd%, St%, MyNSeat%, iSeat%, iRow%, Contgrob%

Dim r%, rr%, i%, ii%, v%, Last%

Const ch As String * 1 = " "

'========================================

Range(Range("A3:E3"), Range("A3:E3").End(xlDown)).ClearContents

Range(Range("I3:J3"), Range("I3:J3").End(xlDown)).ClearContents

'========================================

MyStp = [G2]                 '  فرق الارقام

MyNSeat = [G4]          '  بداية رقم الجلوس

Sry = [G6]            '  بداية الرقم السري

MyCon = [G8]                '  اجمالي الطلبة

iRow = 3           '  اول صف لوضع البيانات

'========================================

MyStp = MyStp + 1

ib = MyCon Mod MyStp

Contgrob = Int(MyCon / MyStp) + IIf(ib, 1, 0)

If ib Then St = MyCon Mod MyStp

'========================================

For r = 1 To Contgrob

1   NRnd = Int((Rnd * Contgrob) + 1) - 1

    MyNum = NRnd & ch

    If InStr(ch & MyAr, ch & MyNum) Then GoTo 1

    MyAr = MyAr & MyNum

Next

MyAr = Trim(MyAr)

'========================================

iSp = MyStp - 1

For r = 0 To Contgrob - 1

    ii = Split(MyAr)(r)

    iSeat = MyNSeat + (r * MyStp)

    If ib Then

        If ii > NRnd Then v = MyStp - St Else v = 0

        If r = Contgrob - 1 Then iSp = St - 1

    End If

    iSry = Sry + (ii * MyStp) - v

    rr = iRow + r

    Last = (r * MyStp) + iRow

                Range("A" & rr).Value = iSeat

    If iSp Then Range("B" & rr).Value = iSeat + iSp

                Range("C" & rr).Value = iSry

    If iSp Then Range("D" & rr).Value = iSry + iSp

                Range("E" & rr).Value = ii

    For i = 0 To iSp

                Range("I" & Last).Offset(i, 0).Value = iSeat + i

                Range("J" & Last).Offset(i, 0).Value = iSry + i

    Next

Next

'========================================

End Sub

رابط هذا التعليق
شارك
saffaa

saffaa

قام بنشر
قام بنشر (معدل)

السلام عليكم

تم اعادة ترتيب الكود ليظهر الخلايا بشكل واضح

ليتم التغيير فيه حسب الطلب


Option Explicit


Sub kh_Rnd_Num()

Dim ib As Boolean

Dim Sry, iSry

Dim MyAr$, MySr$, MyNum$

Dim MyCon%, MyStp%, iSp%, NRnd%, St%, MyNSeat%, iSeat%, iRow%, Contgrob%

Dim r%, rr%, i%, ii%, v%, Last%

Const ch As String * 1 = " "

'========================================

Range(Range("A3:E3"), Range("A3:E3").End(xlDown)).ClearContents

Range(Range("I3:J3"), Range("I3:J3").End(xlDown)).ClearContents

'========================================

MyStp = [G2]				 '  فرق الارقام

MyNSeat = [G4]		  '  بداية رقم الجلوس

Sry = [G6]			'  بداية الرقم السري

MyCon = [G8]				'  اجمالي الطلبة

iRow = 3		   '  اول صف لوضع البيانات

'========================================

MyStp = MyStp + 1

ib = MyCon Mod MyStp

Contgrob = Int(MyCon / MyStp) + IIf(ib, 1, 0)

If ib Then St = MyCon Mod MyStp

'========================================

For r = 1 To Contgrob

1   NRnd = Int((Rnd * Contgrob) + 1) - 1

	MyNum = NRnd & ch

	If InStr(ch & MyAr, ch & MyNum) Then GoTo 1

	MyAr = MyAr & MyNum

Next

MyAr = Trim(MyAr)

'========================================

iSp = MyStp - 1

For r = 0 To Contgrob - 1

	ii = Split(MyAr)(r)

	iSeat = MyNSeat + (r * MyStp)

	If ib Then

		If ii > NRnd Then v = MyStp - St Else v = 0

		If r = Contgrob - 1 Then iSp = St - 1

	End If

	iSry = Sry + (ii * MyStp) - v

	rr = iRow + r

	Last = (r * MyStp) + iRow

				Range("A" & rr).Value = iSeat

	If iSp Then Range("B" & rr).Value = iSeat + iSp

				Range("C" & rr).Value = iSry

	If iSp Then Range("D" & rr).Value = iSry + iSp

				Range("E" & rr).Value = ii

	For i = 0 To iSp

				Range("I" & Last).Offset(i, 0).Value = iSeat + i

				Range("J" & Last).Offset(i, 0).Value = iSry + i

	Next

Next

'========================================

End Sub

بعد اذنكم ضعوا الكود في هذا الملف الموجود اسفل المشاركة

مع رجاء ان يبدأ من العمود التاني B3 الى F3

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

جزاك الله خيرا استاي خبور

السري خبور.rar 13.04K 5 عدد مرات التحميل

تم تعديل بواسطه saffaa
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

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



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept