تعديل كود برمجي لحذف السجلات المكررة

اخى مالك

هذه الدالة مكتوبة اساسا لحذف التكرار فى السجل كاملا

و الموضوع موجود تفصيلا فى هذا الموضوع

/index.php?showtopic=228053&st=0&p=1131648&fromsearch=1entry1131648

عموما لكى تقارن السجلات فى حقل الترقيم التلقائى

اليك الدالة المعدلة

Public Sub DeleteDuplicateRecords(strTableName As String, Optional strfldname 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 لن يتم الترتيب على اساس الحقول من نوع
    If Len(strfldname) > 0 Then
    strSQL = strSQL & strfldname
    Else
    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)

    End If
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 Len(strfldname) > 0 Then
             'If IsAutoNumber(fld) = False And fld.Name = strfldname Then
                If fld.Value <> rst2.Fields(fld.Name).Value Then
                GoTo NextRecord
                End If
             'End If
            Else
              'If IsAutoNumber(fld) = False Then
            'اذا كانت قيمة الحقل غير مكررة انتقل الى السجل التالى
            'و اذا كانت مكررة انتقل الى الحقل التالى فى نفس السجل و قارن القيمة
                If fld.Value <> rst2.Fields(fld.Name).Value Then
                GoTo NextRecord
                End If
              '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

بارك الله بك اخي ابو يوسف

لقد نسيت من اين اتيت بالمثال

كل الاحترام

+1