الحصول على الأرقام الشاغرة

[أبو هادي]

السلام عليكم

هذا الكود سوف ينشئ جدول جديد يحتفظ فيه بالأرقام الشاغرة (غير المشغولة) ، فقط يحتاج منك تبديل إسم الجدول وإسم الحقل في الكود المرفق .

Sub FindMissingSeq()

  Dim dbs As Database

  Dim rst As Recordset

  Dim tdfNew As TableDef

  Dim mis As Recordset

  Dim LastSeq As Long

  Dim FieldName As String

  Dim MasterTable As String

  Dim MissingTable As String

  Dim msg As String

  

  On Error Resume Next

  

  '-------------------------------------------------------------------'

  MasterTable = "TS-t-Transactions"              '-- ÃßÊÈ ÅÓã ÇáÌÏæá --'

  FieldName = "Seq"  '-- ÃßÊÈ ÅÓã ÇáÍÞá ÇáÐí íÍÊæí Úáì ÇáÃÑÞÇã ÇáãÓáÓáÉ --'

  '-------------------------------------------------------------------'

  

  Set dbs = CurrentDb

  Set rst = dbs.OpenRecordset(MasterTable, dbOpenSnapshot)

  rst.Sort = FieldName

  Set rst = rst.OpenRecordset

  

  MissingTable = MasterTable & "_Missing_" & FieldName

  Set mis = dbs.OpenRecordset(MissingTable, dbOpenDynaset)

  If Err.Number = 3078 Then

    Set tdfNew = dbs.CreateTableDef(MissingTable)

    With tdfNew

      .Fields.Append .CreateField("From_" & FieldName, dbLong)

      .Fields.Append .CreateField("To_" & FieldName, dbLong)

      .Fields.Append .CreateField("Records", dbLong)

    End With

    dbs.TableDefs.Append tdfNew

    Set mis = dbs.OpenRecordset(MissingTable, dbOpenDynaset)

  Else

    DoCmd.Close acTable, MissingTable

    Set mis = dbs.OpenRecordset(MissingTable, dbOpenDynaset)

    With mis

      .MoveFirst

      Do While Not .EOF

        .Delete

        .MoveNext

      Loop

    End With

  End If

  

  msg = "ãä æÇÍÏ ¿ " & FieldName & " åá ÊÑíÏ Ãä ÊÈÏà ÃÑÞÇã ÍÞá" & vbCrLf & _

        "ÅÐÇ ÃÑÏÊ Ãä ÊÈÏà ãä ÈÏÇíÉ ÇáÃÑÞÇã Ýí ÇáÌÏæá ÅÎÊÑ áÇ"

  

  With rst

    .MoveFirst

    If vbYes = MsgBox(msg, vbYesNo) Then

      LastSeq = 0

    Else

      LastSeq = rst("[" & FieldName & "]")

      .MoveNext

    End If

    

    Do While Not .EOF

      If rst("[" & FieldName & "]") - LastSeq > 1 Then

        mis.AddNew

          mis("[From_" & FieldName & "]") = LastSeq + 1

          mis("[To_" & FieldName & "]") = rst("[" & FieldName & "]") - 1

          mis("[Records]") = rst("[" & FieldName & "]") - LastSeq - 1

        mis.Update

      End If

      LastSeq = rst("[" & FieldName & "]")

      .MoveNext

    Loop

  End With

  

  mis.Close

  rst.Close

  Set dbs = Nothing

  

  DoCmd.OpenTable MissingTable, , acReadOnly

End Sub

هذا الكود يصلح لحقل رقمي فقط .

الكتابة العربية الموجودة بالكود كالتالي :

1 - أكتب اسم الجدول

2 - أكتب اسم الحقل الذي يحتوي على الأرقام المسلسلة

3 - هل تريد أن تبدأ أرقام حقل ..... من واحد ؟

4 - إذا أردت أن تبدأ من بداية الأرقام في الجدول اختر لا

تحياتي

تم تعديل يوليو 17, 2003 بواسطه أبو هادي

[ashraf]

مثال آخر

ولكن مش بحلاوة مثال أبو هادي

lost.zip

[أبو هادي]

السلام عليكم

إضافة تحسينات كثيرة وأهمها عرض النتيجة بنفس النموذج وإمكانية حذف جدول الشواغر .

تحياتي .

MissingSeq.zip