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

**دغيدى** · يناير 12, 2012

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

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

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

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

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

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

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

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

تم تعديل يناير 12, 2012 بواسطه دغيدى

**عبدالله المجرب** · يناير 12, 2012

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

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

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

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

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


    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

**دغيدى** · يناير 12, 2012

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

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

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

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

الزير · يناير 12, 2012


Set myrange = Range("D3", [D1000])

    myrange.ClearContents

   ' myrange.Interior.ColorIndex = xlNone

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

جرب هذا

**دغيدى** · يناير 12, 2012


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

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

أشكركم

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

**الـعيدروس** · يناير 12, 2012

السلام عليكم

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


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

**دغيدى** · يناير 13, 2012

أخى الفاضل العيدروس

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

أثابكم الله على ماتقدموه من خير ..

شكرا لكم

**عبدالله باقشير** · يناير 19, 2012

السلام عليكم

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

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

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

شاهد المرفق

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

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

**محمدي عبد السميع** · يناير 19, 2012

العالم العلامة والبحر الفهامه خبور خير

أفاض الله عليك بنعمه الكثيرة

آمين يارب العالمين

**خالد الشاعر** · يناير 20, 2012

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

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

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

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

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

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

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

saffaa · يناير 20, 2012

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

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

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

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

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

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

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

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

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

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

**خالد الشاعر** · يناير 20, 2012

استاذ saffaa

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

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

هذا ما اقصد

**عبدالله باقشير** · يناير 20, 2012

السلام عليكم

جمعة مباركة

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


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

**خالد الشاعر** · يناير 20, 2012

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

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

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

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

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

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

تم تعديل يناير 20, 2012 بواسطه khhanna

saffaa · يناير 20, 2012

وهل لاحظت اخي

khhanna

عدم تغييرارقام المجموعه الاخيره

وما رأيك في ذ1لك ؟

**خالد الشاعر** · يناير 20, 2012

استاذ saffaa

نعم الرقم الاخير ثابت فى الرقم السرى فى جميع الاحوال

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

**خالد الشاعر** · يناير 21, 2012

للرفع

**عبدالله باقشير** · يناير 21, 2012

السلام عليكم

شاهد المرفق

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

**خالد الشاعر** · يناير 21, 2012

_{استاذى خبور خير}

_{هذا ابداع جديد من ابداعاتك}

_{لمساهمة فى تطوير العملية التعليمية}

_{جزاك الله كل خير}

**خالد الشاعر** · يناير 22, 2012

بعد اذن استاذى الجليل خبور

تم اضافة بعد التنسيق للملف و للافادة للجميع

و شكرا

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

saffaa · يناير 22, 2012

الازرار لاتعمل والتنسيق جيد

ولكن نريد ارقام الجلوس تبدأ من العمود الثاني ليكون جيد الطباعه

saffaa · يناير 22, 2012

لماذا تغلق الملف بباسوورد

هل اغلقه صاحبه العلامه خبورعليك نحن نبيع كما اشترينا

حكايه الحمايه سيئه

**خالد الشاعر** · يناير 22, 2012

استاذ saffaa

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

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

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

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

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

و شكراً

السري خبور.rar

تم تعديل يناير 23, 2012 بواسطه اا عبدالله المجرب اا

**عبدالله باقشير** · يناير 23, 2012

السلام عليكم

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

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


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 · يناير 23, 2012

السلام عليكم

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

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


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 عدد مرات التحميل

تم تعديل يناير 23, 2012 بواسطه saffaa

تسجيل الدخول

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

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

دغيدى

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

دغيدى

الزير

دغيدى

الـعيدروس

دغيدى

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

محمدي عبد السميع

خالد الشاعر

saffaa

خالد الشاعر

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

خالد الشاعر

saffaa

خالد الشاعر

خالد الشاعر

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

خالد الشاعر

خالد الشاعر

saffaa

saffaa

خالد الشاعر

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

saffaa

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information