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

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

haniameen

بواسطه haniameen
في قسم الأكسيس Access

 مشاركة

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

haniameen

haniameen

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

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

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

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

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

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

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

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

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

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

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

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

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

 

 

 

 

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

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

ابوخليل

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

السلام عليكم

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

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

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

  • Like 1
  • Thanks 3
رابط هذا التعليق
شارك
king5star

king5star

قام بنشر
قام بنشر
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 فاذا كان لديك قليلاً من الوقت لشرحها هى وادواتها اكون لك شاكراً .

  • Like 2
رابط هذا التعليق
شارك
عبد الفتاح كيرة

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

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

وفقكم الله 

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

  • Like 1
رابط هذا التعليق
شارك
haniameen

haniameen

قام بنشر
  • الكاتب
قام بنشر
3 ساعات مضت, ابوخليل said:

السلام عليكم

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

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

 

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك
jjafferr

jjafferr

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

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

 

بسبب وقتي الضيق هذه الايام ، فانا انزور المنتدى في الليل فقط: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

  • Thanks 1
رابط هذا التعليق
شارك
haniameen

haniameen

قام بنشر
  • الكاتب
قام بنشر
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

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

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

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

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

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

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

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

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

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


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

 

تم تعديل بواسطه عبد الفتاح كيرة
إضافة كود رقم المظروف
  • Thanks 1
رابط هذا التعليق
شارك
haniameen

haniameen

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

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

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

و تستدعى هكذا

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

 

 

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

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

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

 

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

 

  • Like 1
رابط هذا التعليق
شارك
ابوخليل

ابوخليل

قام بنشر
قام بنشر
في ٩‏/٧‏/٢٠١٨ at 18:27, king5star said:

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

 

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

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

:welcomeani:

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

 

  • Like 1
رابط هذا التعليق
شارك
عبد الفتاح كيرة

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

قام بنشر
قام بنشر
في ١٠‏/٧‏/٢٠١٨ 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

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

  • Like 1
رابط هذا التعليق
شارك
عبد الفتاح كيرة

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

قام بنشر
قام بنشر (معدل)
في ١٠‏/٧‏/٢٠١٨ 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

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

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

 

تم تعديل بواسطه عبد الفتاح كيرة
  • Like 1
رابط هذا التعليق
شارك
عبد الفتاح كيرة

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

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

Do Until rs.EOF

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

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

rs.Edit

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

أول تعليمة 

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

كما يلى

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

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

قام بنشر
قام بنشر
في ١٠‏/٧‏/٢٠١٨ 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

 

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

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

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

rs.Close Set rs = Nothing

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

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

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

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

وفقكم الله

  • Thanks 2
رابط هذا التعليق
شارك
haniameen

haniameen

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

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

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

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

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

وفقكم الله

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

  • Like 1
رابط هذا التعليق
شارك

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

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



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

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

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

Important Information

  I accept