مطلوب توزيع الرقم السري على الغلاف والمظروف

haniameen · يوليو 5, 2018

إلى أخواني المبرمجين

في جدول الطلاب يوجد حقل الرقم السري sery وحقل المجموعة Group

أولا استخراج رقم الغلاف بناء على الرقم السري والمجموعة :

المطلوب كل مجموعة تقسم بداخلها إلى 50 سجل بالترتيب وكل 50 سجل يسمى غلاف

يعني مثلا : المجموعة رقم 1 بها 33 غلاف لأن عدد سجلاتها 1650 ( يعني ارقام الأغلافة في المجموعة الأولى تبدأ من 1 : 33) لأننا قسمنا عدد سجلات المجموعة رقم 1 على 50 اللي هو ( عدد الغلاف )

المجموعة رقم 7 بها 30 غلاف لأن عدد سجلاتها 1500 ( يعني أرقام الأغلفة في المجموعة السابعة تبدأ من 1 : 30 )

المطلوب عمل هذا برمجيا من خلال نموذج او استعلام بحيث عندما نتختار رقم المجموعة يتم استخراج ارقام الأغلفة لكل مجموعة برمجيا

ملحوظة ( كل 50 طالب مشتركين في رقم غلاف واحد داخل المجموعة الواحدة )

ثانيا رقم المظروف بناء على الرقم السري فقط ولا دخل لرقم المجموعة في الموضوع ودي أسهل شوية

كل 50 رقم سري في مظروف واحد بالترتيب

يعني عندنا عدد الطلاب بناء على الأرقام السرية 15864 على 50 يعطينا 318 مظروف ( كل 50 رقم سري في مظروف واحد )

معلش أنا طرحت الفكرتين مع بعض لأنني اعتقد انهما متقاربين في الفكرة

رقم الغلاف والمظروف.rar

**ابوخليل** · يوليو 9, 2018

السلام عليكم

تفضل تم عمل اللازم

البيانات كثيرة جدا لذا ستلاحظ الوقت الذي يستغرقه تنفيذ الكود

Private Sub zer1_Click()
   On Error Resume Next
   DoCmd.Hourglass True
   Dim rs1 As Recordset
   Dim rs2 As Recordset
   Dim i, ii, iii As Long
   Dim r As Integer
   Dim rr As Integer
   Set rs1 = CurrentDb.OpenRecordset("SELECT Students.Group FROM Students GROUP BY Students.Group ORDER BY Students.Group")
   Set rs2 = CurrentDb.OpenRecordset("SELECT Students.sery, Students.Group, Students.kolaf, Students.mazroof FROM Students ORDER BY Students.Group")
   rs1.MoveLast: rs1.MoveFirst
   rs2.MoveLast: rs2.MoveFirst
   For i = 1 To rs1.RecordCount
   r = rs1!Group
   For ii = 1 To rs2.RecordCount
   rr = rr + 1
   For iii = 1 To 50
   If rs2!Group = r Then
   rs2.Edit
   rs2!kolaf = rr
   rs2.Update
   rs2.MoveNext
   End If
   Next iii
  Next ii
     rr = 0
   rs1.MoveNext
    Next i
   DoCmd.Hourglass False
  MsgBox "تم التوزيع بنجاح"
   Set rs1 = Nothing
   Set rs2 = Nothing
End Sub

Private Sub zer2_Click()
On Error Resume Next
   DoCmd.Hourglass True
   Dim rs1 As Recordset
   Dim i, ii As Long
   Dim r As Integer
   Set rs1 = CurrentDb.OpenRecordset("SELECT Students.sery, Students.mazroof FROM Students ORDER BY Students.sery")
   rs1.MoveLast: rs1.MoveFirst
   For i = 1 To rs1.RecordCount Step 50
   r = r + 1
   For ii = 1 To 50
   rs1.Edit
   rs1!mazroof = r
   rs1.Update
   rs1.MoveNext
    Next ii
     Next i
   DoCmd.Hourglass False
  MsgBox "تم التوزيع بنجاح"
   Set rs1 = Nothing
  End Sub

رقم الغلاف والمظروف2.rar

king5star · يوليو 9, 2018

2 ساعات مضت, ابوخليل said:

السلام عليكم

تفضل تم عمل اللازم

البيانات كثيرة جدا لذا ستلاحظ الوقت الذي يستغرقه تنفيذ الكود


Private Sub zer1_Click()
   On Error Resume Next
   DoCmd.Hourglass True
   Dim rs1 As Recordset
   Dim rs2 As Recordset
   Dim i, ii, iii As Long
   Dim r As Integer
   Dim rr As Integer
   Set rs1 = CurrentDb.OpenRecordset("SELECT Students.Group FROM Students GROUP BY Students.Group ORDER BY Students.Group")
   Set rs2 = CurrentDb.OpenRecordset("SELECT Students.sery, Students.Group, Students.kolaf, Students.mazroof FROM Students ORDER BY Students.Group")
   rs1.MoveLast: rs1.MoveFirst
   rs2.MoveLast: rs2.MoveFirst
   For i = 1 To rs1.RecordCount
   r = rs1!Group
   For ii = 1 To rs2.RecordCount
   rr = rr + 1
   For iii = 1 To 50
   If rs2!Group = r Then
   rs2.Edit
   rs2!kolaf = rr
   rs2.Update
   rs2.MoveNext
   End If
   Next iii
  Next ii
     rr = 0
   rs1.MoveNext
    Next i
   DoCmd.Hourglass False
  MsgBox "تم التوزيع بنجاح"
   Set rs1 = Nothing
   Set rs2 = Nothing
End Sub

Private Sub zer2_Click()
On Error Resume Next
   DoCmd.Hourglass True
   Dim rs1 As Recordset
   Dim i, ii As Long
   Dim r As Integer
   Set rs1 = CurrentDb.OpenRecordset("SELECT Students.sery, Students.mazroof FROM Students ORDER BY Students.sery")
   rs1.MoveLast: rs1.MoveFirst
   For i = 1 To rs1.RecordCount Step 50
   r = r + 1
   For ii = 1 To 50
   rs1.Edit
   rs1!mazroof = r
   rs1.Update
   rs1.MoveNext
    Next ii
     Next i
   DoCmd.Hourglass False
  MsgBox "تم التوزيع بنجاح"
   Set rs1 = Nothing
  End Sub

رقم الغلاف والمظروف2.rar

والله اخى @ابوخليل حاولت افعلها ولكنها لم تنجح معى لعملي انها سوف تحتاج الى مكتبة Recordset فاذا كان لديك قليلاً من الوقت لشرحها هى وادواتها اكون لك شاكراً .

**عبد الفتاح كيرة** · يوليو 9, 2018

وفقكم الله

‏أسباب دفع العقوبة عشرة، وهي:
🔹ثلاثة من العبد:
- التوبة
- الاستغفار
- الحسنات الماحية
🔹ثلاثة من الناس:
- دعاءالمؤمنين
- إهداءالعمل الصالح له
- شفاعتهﷺ
🔹أربعة يبتديها الله:
- المصائب المكفرة في الدنيا
- الفتنة في البرزخ
- أهوال القيامة
- مغفرة الله بفضله

haniameen · يوليو 9, 2018

3 ساعات مضت, ابوخليل said:

السلام عليكم

تفضل تم عمل اللازم

البيانات كثيرة جدا لذا ستلاحظ الوقت الذي يستغرقه تنفيذ الكود

الصراحة أخي ابو خليل كما قال الكتاب .... وبسم الله ما شاء اله على فهم الموضوع ...... خفت أن يخونني التعبير في توصيل ما اريد

جزاك الله عنا خير الجزاء

لكن حاولت فهم الكود ولكن فشلت لعلك تلقى الوقت المناسب لشرحه لنا ولأعضاء المنتدى حتى نستفيد من علمك الغزير

**jjafferr** · يوليو 9, 2018

السلام عليكم ورحمة الله وبركاته

بسبب وقتي الضيق هذه الايام ، فانا انزور المنتدى في الليل فقط :smile:

البارحة اشتغلت على البرنامج ، ولكن جزئية بسيطة منه لم تشتغل ، فنظرت في البرنامج الليلة ، واذا بأخوي ابو خليل قد وضع اجابته :smile:

فكنت سأتوقف عن العمل ، ولكن ملاحظته عن سرعة البرنامج لفت نظري ، واردت ان ارى اذا استطيع ان اتغلب على بطئ العملية ، واعتقد بأني بالفعل توفقت والحمدلله :smile:

Option Compare Database
'Option Explicit

Private Sub cmd_Go_Click()
On Error GoTo err_cmd_Go_Click

   
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim rstG As DAO.Recordset
    
'الغلاف
    Z = 1
    Set dbs = CurrentDb
    Set rstG = dbs.OpenRecordset("SELECT Group FROM Students GROUP BY Group ORDER BY Group")
    rstG.MoveLast: rstG.MoveFirst
    RCg = rstG.RecordCount
    
    For k = 1 To RCg
    
        Set rst = dbs.OpenRecordset("Select * From Students Where [Group]=" & rstG!Group & " Order By Sery, Group")
        'Set rst = dbs.OpenRecordset("Select * From Students Order By Sery, Group")
        rst.MoveLast: rst.MoveFirst
        RC = rst.RecordCount
    
        If RC / 50 = Int(RC / 50) Then
            Groups = RC / 50
        Else
            Groups = Int(RC / 50) + 1
        End If
    
        Counter = 0
    
        For i = 1 To Groups
            For j = 1 To 50
                Counter = Counter + 1
            
                rst.Edit
                    rst!kolaf = i
                rst.Update
            
                rst.MoveNext
            Next j
        
            'rst.MoveNext
        Next i
        
        
        rstG.MoveNext
    Next k
    
    
Start_mazroof:
    rstG.Close: Set rstG = Nothing


'الظرف
    Z = 2
    Set rst = dbs.OpenRecordset("Select * From Students Order By Sery, Group")
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    If RC / 50 = Int(RC / 50) Then
        Groups = RC / 50
    Else
        Groups = Int(RC / 50) + 1
    End If
    
    For i = 1 To Groups
        For j = 1 To 50
            
            rst.Edit
                rst!mazroof = i
            rst.Update
            
            rst.MoveNext
        Next j
        
        'rst.MoveNext
    Next i
    
    
Exit_cmd_Go_Click:
    rst.Close: Set rst = Nothing: dbs.Close
    
    MsgBox "Done"
    
Exit Sub
err_cmd_Go_Click:

    If Err.Number = 3021 And Z = 1 Then
        Resume Start_mazroof
    ElseIf Err.Number = 3021 And Z = 2 Then
        Resume Exit_cmd_Go_Click
    ElseIf Err.Number = 3052 Then
        Resume
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Sub

جعفر

رقم الغلاف والمظروف.zip

haniameen · يوليو 9, 2018

59 دقائق مضت, jjafferr said:

السلام عليكم ورحمة الله وبركاته

بسبب وقتي الضيق هذه الايام ، فانا انزور المنتدى في الليل فقط :smile:

البارحة اشتغلت على البرنامج ، ولكن جزئية بسيطة منه لم تشتغل ، فنظرت في البرنامج الليلة ، واذا بأخوي ابو خليل قد وضع اجابته :smile:

فكنت سأتوقف عن العمل ، ولكن ملاحظته عن سرعة البرنامج لفت نظري ، واردت ان ارى اذا استطيع ان اتغلب على بطئ العملية ، واعتقد بأني بالفعل توفقت والحمدلله :smile:


Option Compare Database
'Option Explicit

Private Sub cmd_Go_Click()
On Error GoTo err_cmd_Go_Click

   
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim rstG As DAO.Recordset
    
'الغلاف
    Z = 1
    Set dbs = CurrentDb
    Set rstG = dbs.OpenRecordset("SELECT Group FROM Students GROUP BY Group ORDER BY Group")
    rstG.MoveLast: rstG.MoveFirst
    RCg = rstG.RecordCount
    
    For k = 1 To RCg
    
        Set rst = dbs.OpenRecordset("Select * From Students Where [Group]=" & rstG!Group & " Order By Sery, Group")
        'Set rst = dbs.OpenRecordset("Select * From Students Order By Sery, Group")
        rst.MoveLast: rst.MoveFirst
        RC = rst.RecordCount
    
        If RC / 50 = Int(RC / 50) Then
            Groups = RC / 50
        Else
            Groups = Int(RC / 50) + 1
        End If
    
        Counter = 0
    
        For i = 1 To Groups
            For j = 1 To 50
                Counter = Counter + 1
            
                rst.Edit
                    rst!kolaf = i
                rst.Update
            
                rst.MoveNext
            Next j
        
            'rst.MoveNext
        Next i
        
        
        rstG.MoveNext
    Next k
    
    
Start_mazroof:
    rstG.Close: Set rstG = Nothing


'الظرف
    Z = 2
    Set rst = dbs.OpenRecordset("Select * From Students Order By Sery, Group")
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    
    If RC / 50 = Int(RC / 50) Then
        Groups = RC / 50
    Else
        Groups = Int(RC / 50) + 1
    End If
    
    For i = 1 To Groups
        For j = 1 To 50
            
            rst.Edit
                rst!mazroof = i
            rst.Update
            
            rst.MoveNext
        Next j
        
        'rst.MoveNext
    Next i
    
    
Exit_cmd_Go_Click:
    rst.Close: Set rst = Nothing: dbs.Close
    
    MsgBox "Done"
    
Exit Sub
err_cmd_Go_Click:

    If Err.Number = 3021 And Z = 1 Then
        Resume Start_mazroof
    ElseIf Err.Number = 3021 And Z = 2 Then
        Resume Exit_cmd_Go_Click
    ElseIf Err.Number = 3052 Then
        Resume
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Sub

جعفر

رقم الغلاف والمظروف.zip

كم انت عظيم أخي جعفر أنم وأخي أبو خليل بارك اله فيكم وجزاكم الله عنا خير الجزاء

هناك مشكلة قابلتني في كود الأخ ابو خليل في تسلسل الأغلفة تبعا لتسلسل الرقم السري

ولكن فوجئت بالحل عندك

أنا عاجز عن شكركما أنتما الاثنين وبارك اله فيكم
أخيكم الصغير هاني

**عبد الفتاح كيرة** · يوليو 9, 2018

هذا مختصر و سريع

أنشأت وظيفة لهذا الغرض


Function myfun(fs As Integer)
Dim rs As Recordset
   Dim rrr As Integer
   rrr = 1
   Dim i, ii, iii As Integer
   Dim r As Integer
   Dim rr As Integer
  rr = 1
 Set rs = CurrentDb.OpenRecordset("SELECT Students.sery, Students.Group, Students.kolaf, Students.mazroof FROM Students where (group =" & fs & ") order  by group")
   rs.MoveFirst
   Do Until rs.EOF
        rs.Edit
            rs!kolaf = rr
            rs.Update
    If rrr Mod 50 = 0 Then
   rr = rr + 1
   End If
    rrr = rrr + 1
   rs.MoveNext
   Loop
   rs.MoveFirst
   rr = 1
   rrr = 1
   rs.Close
   Set rs = Nothing
End Function

و تستدعى هكذا

Private Sub test1_Click()
Dim i As Integer
   For i = 1 To 11
        myfun i
    Next i
End Sub

و التنفيذ سريع حوالى 7 ثوان مع ملاحظة أن بالجدول أكثر من 15 ألف سجل

كيرة رقم الغلاف والمظروف2003.mdb

كيرة رقم الغلاف والمظروف.accdb

و هذا الكود للمظروف

Private Sub maz_Click()
Dim rs As Recordset
   Dim rr As Integer
      Dim rrr As Integer
  rr = 1
  rrr = 1
 Set rs = CurrentDb.OpenRecordset("SELECT Students.sery, Students.Group, Students.kolaf, Students.mazroof FROM Students  order  by sery")
   Do Until rs.EOF
        rs.Edit
            rs!mazroof = rr
            rs.Update
    If rrr Mod 50 = 0 Then
   rr = rr + 1
   End If
   rs.MoveNext
   rrr = rrr + 1
   Loop
  rs.Close
Set rs = Nothing
End Sub

تم تعديل يوليو 10, 2018 بواسطه عبد الفتاح كيرة
إضافة كود رقم المظروف

haniameen · يوليو 10, 2018

19 ساعات مضت, عبد الفتاح كيرة said:

هذا مختصر و سريع

أنشأت وظيفة لهذا الغرض

و تستدعى هكذا

و التنفيذ سريع حوالى 7 ثوان مع ملاحظة أن بالجدول أكثر من 15 ألف سجل

كيرة رقم الغلاف والمظروف2003.mdb

كيرة رقم الغلاف والمظروف.accdb

و هذا الكود للمظروف

أشكرك أستاذي عبد الفتاح على هذا الاهتمام على الرغم من أن الأستاذ جعفر وأبو خليل قد قاموا بالواجب سأقوم بتجريب الكود ودراسته والرد عليك قريبا ان شاء الله

**عبد الفتاح كيرة** · يوليو 10, 2018

لا نتعدى على معلمينا و أساتذتنا

لكنه تعدد الردود و تبادل الأفكار

**ابوخليل** · يوليو 11, 2018

في ٩‏/٧‏/٢٠١٨ at 18:27, king5star said:

فاذا كان لديك قليلاً من الوقت لشرحها هى وادواتها اكون لك شاكراً .

في ٩‏/٧‏/٢٠١٨ at 19:37, haniameen said:

لكن حاولت فهم الكود ولكن فشلت لعلك تلقى الوقت المناسب لشرحه لنا ولأعضاء المنتدى حتى نستفيد من علمك الغزير

:welcomeani:

كما تلاحظون الحلول التالية افضل فانا احيل الطلب الى اساتذتنا الكرام مع الشكر والتقدير

**عبد الفتاح كيرة** · يوليو 11, 2018

إن شاء الله لما نرجع من العمل أقوم بما تيسر من الشرح

مع أنى لم أعرف نتيجة الكود الذى أدرجته

**عبد الفتاح كيرة** · يوليو 11, 2018

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

Function myfun(fs As Integer)

بداية الوظيفة

واسمها

وما بين القوسين متغير تطلبه عند استدعائها

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

Dim rs As Recordset Dim rrr As Integer rrr = 1 Dim i, ii, iii As Integer Dim r As Integer Dim rr As Integer

حجز مكان فى الذاكرة لتخزين السجلات عنوانه rs من النوع recordset

ثم مجموعة من المتغيرات من النوع الرقمى تعرف عند استخدامها

**عبد الفتاح كيرة** · يوليو 11, 2018

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

Set rs = CurrentDb.OpenRecordset("SELECT Students.sery, Students.Group, Students.kolaf, Students.mazroof FROM Students where (group =" & fs & ") order by group")

خزن فى قاعدة البيانات الحالية currentdb جملة الاستعلام التالية

مع ملاحظة

Where (group=)

Fs

اسم المتغير الذى سيتم استدعاء الوظيفة به

وعند الاستدعاء نجعل المتغير يساوى رقم المجموعة من 1 إلى 11

داخل حلقة تكرارية

والبقية تأتى إن تيسر الحال

تم تعديل يوليو 11, 2018 بواسطه عبد الفتاح كيرة

**عبد الفتاح كيرة** · يوليو 13, 2018

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

Do Until rs.EOF

نفذ الآتى من التعليمات حتى كلمة loop

ما لم تصل إلى نهاية الريكورد سيت rs

rs.Edit

بداية التعليمات داخل حلقة do >>> loop

أول تعليمة

قم بالتعديل فى مجموعة السجلات rs

كما يلى

تم تعديل يوليو 13, 2018 بواسطه عبد الفتاح كيرة

**عبد الفتاح كيرة** · يوليو 13, 2018

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

rs!kolaf = rr rs.Update

اجعل حقل غلاف فى rs =

المتغير rr

وبدايته هنا = 1

لكن طبعا مع الحلقة سيزيد

بدون سطر update
كأنك لم تعدل فى السجلات

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

If rrr Mod 50 = 0 Then rr = rr + 1 End If

بعد تعديل أول سجل و جعل رقم الغلاف = 1

تحقق من هذا الشرط

إذا كان باقى قسمة المتغير rrr على 50 = 0

يعنى عدلنا 50 سجلا

اجعل المتغير rr الذى هو رقم الغلاف يرجع إلى واحد من جديد

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

rs.MoveNext rrr = rrr + 1 Loop

انتقل للسجل التالى

بدون هذا الانتقال يظل الكود يدور حول السجل الأول و يتوقف البرنامج عن العمل بسبب الحلقة

do....... loop

زد rrr بمقدار 1

**عبد الفتاح كيرة** · يوليو 13, 2018

في ١٠‏/٧‏/٢٠١٨ at 01:15, عبد الفتاح كيرة said:

rs.Close Set rs = Nothing

أغلق مجموعة السجلات

ثم اجعلها لا تساوى شيئا

لتنظيف الذاكرة العصماء

أرجو أن أكون قد أفدتك و لو قليلا

وفقكم الله

haniameen · يوليو 13, 2018

4 ساعات مضت, عبد الفتاح كيرة said:

أغلق مجموعة السجلات

ثم اجعلها لا تساوى شيئا

لتنظيف الذاكرة العصماء

أرجو أن أكون قد أفدتك و لو قليلا

وفقكم الله

ربنا يبارك فيك استاذي عبد الفتاح وجزاك الله عنا خير الجزاء

تسجيل الدخول

مطلوب توزيع الرقم السري على الغلاف والمظروف

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

haniameen

ابوخليل

king5star

عبد الفتاح كيرة

haniameen

jjafferr

haniameen

عبد الفتاح كيرة

haniameen

عبد الفتاح كيرة

ابوخليل

عبد الفتاح كيرة

عبد الفتاح كيرة

عبد الفتاح كيرة

عبد الفتاح كيرة

عبد الفتاح كيرة

عبد الفتاح كيرة

haniameen

Join the conversation

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

تصفح الموقع

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

Support

Important Information