وحدة نمطية لحذف السجلات المتكررة ةإبقاء واحد فقط

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

Public Sub DeleteDuplicateRecords(strTableName As String)
    ' حذف السجلات المكررة اذا كانت جميع الحقول متطابقة مع استبعاد حقول الترقيم التلقائى من عملية المقارنة
    Dim rst As DAO.Recordset
    Dim rst2 As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim strSQL As String
    Dim varBookmark As Variant
    Dim i As Integer
    i = 0
    
    Set tdf = DBEngine(0)(0).TableDefs(strTableName)
    strSQL = "SELECT * FROM " & strTableName & " ORDER BY "
    ' ترتيب السجلات للتأكد من أن السجلات المكررة تكون متتالية
    'OLE or Memo لن يتم الترتيب على اساس الحقول من نوع
    For Each fld In tdf.Fields
        If (fld.Type <> dbMemo) And (fld.Type <> dbLongBinary) Then
            strSQL = strSQL & fld.Name & ", "
        End If
    Next fld
    '", "  و هى sql حذف العلامات الزائدة فى نهاية جملة ال
    strSQL = Left(strSQL, Len(strSQL) - 2)
    Set tdf = Nothing

    Set rst = CurrentDb.OpenRecordset(strSQL)
    ' نأخذ نسخة من مجموعة السجلات ليتم المقارنة بها
    Set rst2 = rst.Clone
    rst.MoveNext
    Do Until rst.EOF
        varBookmark = rst.Bookmark
        For Each fld In rst.Fields
    ' استبعاد حقول الترقيم التلقائى من عملية المقارنة
            If IsAutoNumber(fld) = False Then
            'اذا كانت قيمة الحقل غير مكررة انتقل الى السجل التالى
            'و اذا كانت مكررة انتقل الى الحقل التالى فى نفس السجل و قارن القيمة
            If fld.Value <> rst2.Fields(fld.Name).Value Then
                GoTo NextRecord
            End If
            End If
        Next fld
        'احذف السجل المكرر
        rst.Delete
        'عدد السجلات المحذوفة
        i = i + 1
        GoTo SkipBookmark
NextRecord:
        rst2.Bookmark = varBookmark
SkipBookmark:
        rst.MoveNext
    Loop
    rst2.Close
    Set rst2 = Nothing
    rst.Close
    Set rst = Nothing   
    MsgBox IIf(i > 0, "تم حذف عدد " & i & " سجلات مكررة", "لا يوجد سجلات مكررة")
End Sub

Function IsAutoNumber(ByRef fld As Object) As Boolean
'لتحديد ما اذا كان نوع الحقل ترقيم تلقائى ام لا
On Error GoTo ErrHandler
  If TypeOf fld Is ADODB.Field Then
    IsAutoNumber = (fld.Properties("ISAUTOINCREMENT") = True)
  ElseIf TypeOf fld Is DAO.Field Then
    IsAutoNumber = (fld.Attributes And dbAutoIncrField)
  Else
    Err.Raise vbObjectError + 100, "IsAutoNumber()", _
      "Unsupported Field Type argument: " & TypeName(fld)
  End If
ExitHere:
  Exit Function
ErrHandler:
  Debug.Print Err, Err.Description
  Resume ExitHere
End Function

السلام عليكم ... kh202067

شكراً على الرد ,,, ولكن لدي مشكلة مع هذا الكود .....

ويظهر خطأ .... هل المشكلة في قاعدتي أم لمشكلة في طريقة وضع الكود ...
يعني أنا أبيه يعمل مع تشغيل القاعدة ..
هل ممكن ذلك ...؟
 

1.bmp

بسم الله الرحمن الرحيم

اخي الفاضل 

جرب الكود بعد التعديل

Public Function DeleteDuplicateRecords(strTableName As String)
    ' حذف السجلات المكررة اذا كانت جميع الحقول متطابقة مع استبعاد حقول الترقيم التلقائى من عملية المقارنة
    Dim rst As DAO.Recordset
    Dim rst2 As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim strSQL As String
    Dim varBookmark As Variant
    Dim i As Integer
    i = 0
    
    Set tdf = DBEngine(0)(0).TableDefs(strTableName)
    strSQL = "SELECT * FROM " & strTableName & " ORDER BY "
    ' ترتيب السجلات للتأكد من أن السجلات المكررة تكون متتالية
    'OLE or Memo لن يتم الترتيب على اساس الحقول من نوع
    For Each fld In tdf.Fields
        If (fld.Type <> dbMemo) And (fld.Type <> dbLongBinary) Then
            strSQL = strSQL & fld.Name & ", "
        End If
    Next fld
    '", "  و هى sql حذف العلامات الزائدة فى نهاية جملة ال
    strSQL = Left(strSQL, Len(strSQL) - 2)
    Set tdf = Nothing
 
    Set rst = CurrentDb.OpenRecordset(strSQL)
    ' نأخذ نسخة من مجموعة السجلات ليتم المقارنة بها
    Set rst2 = rst.Clone
    rst.MoveNext
    Do Until rst.EOF
        varBookmark = rst.Bookmark
        For Each fld In rst.Fields
    ' استبعاد حقول الترقيم التلقائى من عملية المقارنة
            If IsAutoNumber(fld) = False Then
            'اذا كانت قيمة الحقل غير مكررة انتقل الى السجل التالى
            'و اذا كانت مكررة انتقل الى الحقل التالى فى نفس السجل و قارن القيمة
            If fld.Value <> rst2.Fields(fld.Name).Value Then
                GoTo NextRecord
            End If
            End If
        Next fld
        'احذف السجل المكرر
        rst.Delete
        'عدد السجلات المحذوفة
        i = i + 1
        GoTo SkipBookmark
NextRecord:
        rst2.Bookmark = varBookmark
SkipBookmark:
        rst.MoveNext
    Loop
    
    rst2.Close
    Set rst2 = Nothing
    rst.Close
    Set rst = Nothing
    
    MsgBox IIf(i > 0, "تم حذف عدد " & i & " سجلات مكررة", "لا يوجد سجلات مكررة")
 
End Sub
 
Function IsAutoNumber(ByRef fld As Object) As Boolean
'لتحديد ما اذا كان نوع الحقل ترقيم تلقائى ام لا
On Error GoTo ErrHandler
 
  If TypeOf fld Is DAO.Field Then
    IsAutoNumber = (fld.Attributes And dbAutoIncrField)
  Else
    Err.Raise vbObjectError + 100, "IsAutoNumber()", _
      "Unsupported Field Type argument: " & TypeName(fld)
  End If
 
ExitHere:
  Exit Function
ErrHandler:
  Debug.Print Err, Err.Description
  Resume ExitHere
End Function

السلام عليكم ... شكراً أخت زهرة ...
لا زالت المشكلة ...
مرفق القاعدة ...
الدخول الى F1
user:محمد

pass:1

معذرة على التصميم السيء ...

 

تجربة المدرسة الرقمية.rar

تفضل اخي الكريم

ملفك بعد التعديل

اذا تمت الإجابه على السؤال فلا تنسى الضغط على ( أفضل إجابة )

za-تجربة المدرسة الرقمية-UP.rar

بالتوفيق

جزاك الله خيرا أستاذتنا الكريمة زهرة

شكرا اخت زهرة ...
فعلاً لقد حُلت المشكلة ....
سؤالي ماذا كانت المشكلة بالظبط   ...
وما هو التعديل الذي قمت به ...
تحياتي

nonar كتب:

شكرا اخت زهرة ...

فعلاً لقد حُلت المشكلة ....

سؤالي ماذا كانت المشكلة بالظبط   ...

وما هو التعديل الذي قمت به ...

تحياتي

اخي الكريم

المشكلة كانت في هذين السطرين

If TypeOf fld Is ADODB.Field Then
    IsAutoNumber = (fld.Properties("ISAUTOINCREMENT") = True)