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

سارفق طلبك هذا في موضوع منفصل بعد التاكد من هذا هو المطلوب في المرفق sample.rar

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

السلام عليكم ورحمة الله وبركاته الشكر واصل لجميع المشاركين اعلاه جزاكم الله خيرا وبارك الله فيكم ملاحظة هامة يجب تغيير كود الفرز المربوط بزر فرز عكسي الى الكود ادناه في المرفقات اعلاه لان الكود السابق يفشل في عكس الفرز في بعض الحالات Sub kh_Sort() Dim c As Integer Static ibool As Boolean c = ibool + 2 With Range("I7:J7") Range(.Cells, .Cells.End(xlDown)).Sort .Columns©, xlAscending .Columns©.Activate End With ibool = Not ibool End Sub

السلام عليكم جزاك الله خيرا وبارك الله فيك تقبل تحياتي وشكري

السلام عليكم ترتيب السري لكنترول المدارس الادخال عبر فورم امكانية ادخال البيانات مع فرز ترتيب السري تجهيز طباعة المجموعات ظهور الفورم بكلمة سر وهي 123 ويمكنك تغييرها من بداية كود فورم كلمة السر تفضلوا المرفق اكسل 2003-2007 الرقم السري لكنترول المدارس.rar ================================================================ ملاحظة هامة يجب تغيير كود الفرز المربوط بزر فرز عكسي الى الكود ادناه في المرفقات اعلاه لان الكود السابق يفشل في عكس الفرز في بعض الحالات Sub kh_Sort() Dim c As Integer Static ibool As Boolean c = ibool + 2 With Range("I7:J7") Range(.Cells, .Cells.End(xlDown)).Sort .Columns(c), xlAscending .Columns(c).Activate End With ibool = Not ibool End Sub ================================================================

جزاك الله خيرا

السلام عليكم Sub kh_Sort() Dim c As Integer Static ibool As Boolean c = ibool + 2 With Range("J6:K6") Range(.Cells, .Cells.End(xlDown)).Sort .Columns(c), xlAscending .Activate End With ibool = Not ibool End Sub ممكن اضافة هذا الكود الى اكواد الملف واضافة اسم الكود نهاية كود الترتيب Sub kh_Sort1() With Range("B6:F6") Range(.Cells, .Cells.End(xlDown)).Sort .Columns(5), xlAscending End With End Sub

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

السلام عليكم اليوم تاعبنا المنتدى في تحرير الردود حاولت ارفق الكود هنا تتحول اللغة الى طلاسم المهم تفضل المرفق دوائر1.rar

السلام عليكم تم اضافة الكود الى الملف مع تغيير البدء من العمود 2 السري خبور.rar

السلام عليكم الله يبارك فيك اخي الكريم تقبل تحياتي وشكري

السلام عليكم هذا حسب ما فهمت والله اعلم انتقال البيانات من نموذج الى نموذج اخر.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

أرجو اهتمامك أخى الكريم حمل المرفق2003 -2007 من الرابط التالي http://getfile4.posterous.com/getfile/files.posterous.com/khboor/A6xn96bT9HQDKcGSUF7cQuhwmvs63LQEE0NrbJ9ncP2sSbbctKqOCVitPXMr/suppliers3_LIST2.rar

غير السطر هذا Range("E" & rr).Value = ii بهذا السطر Range("E" & rr).Value = ii + 1

السلام عليكم شاهد المرفق الرقم السري3 خبور.rar

السلام عليكم يتم التعديل عند فتح الملف وايضا عبر زر Option Explicit Option Compare Text Const ch As String * 1 = "^" Sub kh_Start() Dim LastRow As Long With Sheets("List") LastRow = .Range("A2").CurrentRegion.Rows.Count .Range("A2:C" & LastRow).ClearContents End With Addliste Range("Data").Columns(3), Sheets("List").Range("A2") Addliste Range("Data").Columns(4), Sheets("List").Range("B2") Addliste Range("Data").Columns(5), Sheets("List").Range("C2") End Sub Sub Addliste(ColList As Range, MyCol As Range) Dim MyArr, myAry, sp Dim Myitem As String Dim myRank As String Dim kh_Test As Boolean Dim R As Long, i As Long, ii As Long '======================== With ColList For R = 2 To .Rows.Count If Not IsEmpty(.Cells(R, 1)) Then Myitem = Trim(.Cells(R, 1)) & ch If InStr(ch & MyArr, ch & Myitem) = 0 Then MyArr = MyArr & Myitem End If End If Next End With If IsEmpty(MyArr) Then Exit Sub '======================== MyArr = Left(MyArr, Len(MyArr) - 1) myAry = kh_ListSortInArray(Split(MyArr, ch)) '======================== For Each sp In myAry MyCol.Offset(ii, 0).Value = sp ii = ii + 1 Next End Sub '----------------------------------------------------------------- '----------------------------------------------------------------- Function kh_ListSortInArray(myArray) Dim myRank As String Dim kh_Test As Boolean Dim i As Long Do kh_Test = False For i = LBound(myArray) To UBound(myArray) - 1 If myArray(i) > myArray(i + 1) Then myRank = myArray(i) myArray(i) = myArray(i + 1) myArray(i + 1) = myRank kh_Test = True End If Next i Loop While kh_Test = True kh_ListSortInArray = myArray Erase myArray End Function شاهد المرفق 2007 suppliers3_LIST1.rar

السلام عليكم هذا الحل مؤقت ووضعته نتيجة الرفع من قبل صاحب الطلب وانا مازلت اعمل على الملف هذه بسيطه حنعملها في الملف اللاحق ان شاء الله ودمتم في حفظ الله

السلام عليكم جمعة مباركة استبدل الجزئية هذه 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

الاخ الحبيب/ عبدالله المجرب __________حفظه الله ادام الله المحبة فيه جزاك الله خيرا الاخ الحبيب/ دغيدي __________حفظه الله جزاك الله خيرا الاخ الحبيب/ almhb__________حفظه الله جزاك الله خيرا الاخ الحبيب/ هاني بدر__________حفظه الله التنسيق يشمل اللست بما حوى جزاك الله خيرا الاخ الحبيب/ جمال الفار__________حفظه الله جزاك الله خيرا الاخ الحبيب/ ابو عبدالله__________حفظه الله تسلم حبيبي على هذا الشعر الجميل جزاك الله خيرا بارك الله فيكم واكرمكم الله دنيا وآخرة تقبلوا تحياتي وشكري خبور خير

الشكر واصل لجميع المشاركين حفظكم الله ورعاكم لقد غيرت رابط اخر مؤقت للزر مواضيعي في المنتدى جمعت فيه جميع المواضيع الى تاريخنا هذا خبور خير

السلام عليكم شاهد المرفق وتاكد من النتائج الرقم السري2 خبور.rar

السلام عليكم ما رايك بهذا للجدولين معا Option Explicit Sub kh_Rnd_Num() Dim Sry, SpSry, NRnd Dim MyAr$, MySr$, MyNum$ Dim Con%, G%, St%, iRow% Dim r%, i%, ii%, c%, co%, cc%, o% Const ch As String * 1 = "/" '======================================== Range(Range("A3:D3"), Range("A3:D3").End(xlDown)).ClearContents Range(Range("I3:J3"), Range("I3:J3").End(xlDown)).ClearContents '======================================== St = [G2] ' فرق الارقام G = [G4] ' بداية رقم الجلوس Sry = [G6] ' بداية الرقم السري Con = [G8] ' اجمالي الطلبة iRow = 3 ' اول صف لوضع البيانات '======================================== For r = 1 To Con Step St + 1 MySr = MySr & " " & Sry i = i + 1 Sry = Sry + St + 1 Next '======================================== For r = 1 To i 1 NRnd = Int((Rnd * i) + 1) MyNum = NRnd & ch If InStr(ch & MyAr, ch & MyNum) Then GoTo 1 MyAr = MyAr & MyNum Next '======================================== For r = 0 To i - 1 o = 0 ii = Split(MyAr, ch)(r) - 1 SpSry = Split(Trim(MySr))(ii) Cells(iRow + r, "A").Value = G + co Cells(iRow + r, "C").Value = SpSry For c = 0 To St cc = (r * (St + 1)) + iRow If co = Con Then Exit For Cells(cc, "I").Offset(c, 0).Value = G + co Cells(cc, "J").Offset(c, 0).Value = SpSry + c co = co + 1: o = o + 1 Next Cells(iRow + r, "B").Value = G + co - 1 Cells(iRow + r, "D").Value = SpSry + o - 1 Next '======================================== End Sub الرقم السري1 خبور.rar

السلام عليكم شاهد المحاولة هذه استخدمنا هذا الكود Option Explicit Sub kh_Rnd_Num() Const ch As String * 1 = "/" Dim MyAr$, MySr$, MyNum$ Dim Sr, NRnd, SP Dim R%, RR%, Con%, G%, St%, i%, ii% '======================================== Range(Range("A3:D3"), Range("A3:D3").End(xlDown)).ClearContents '======================================== St = [G2] ' فرق الارقام G = [G4] ' بداية رقم الجلوس Sr = [G6] ' بداية الرقم السري Con = [G8] ' اجمالي الطلبة RR = 3 ' اول صف لوضع البيانات '======================================== For R = 1 To Con Step St + 1 Cells(RR + i, "A") = G Cells(RR + i, "b") = G + St MySr = MySr & " " & Sr & ch & Val(Sr + St) i = i + 1 G = G + St + 1 Sr = Sr + St + 1 Next MySr = Trim(MySr) '======================================== For R = 1 To i 1 NRnd = Int((Rnd * i) + 1) MyNum = NRnd & ch If InStr(ch & MyAr, ch & MyNum) Then GoTo 1 MyAr = MyAr & MyNum Next '======================================== For R = 0 To i - 1 ii = Split(MyAr, ch)(R) - 1 SP = Split(MySr)(ii) Cells(RR + R, "C") = Split(SP, ch)(0) Cells(RR + R, "D") = Split(SP, ch)(1) Next End Sub الرقم السري خبور.rar

السلام عليكم بعد كتابة ارقام الجلوس نفذ هذا الكود Sub kh_copy() Dim R%, M% For R = 7 To Cells(1000, "D").End(xlUp).Row M = Application.Match(Cells(R, "A"), [Sheet1!A:A], 0) Cells(R, "D").Copy Sheets("Sheet1").Cells(M, "D") Cells(R, "D") = Empty Next End Sub