اليكم اخوانى
هذه الهدية المتواضعة
و هى عبارة عن كود لحذف السجلات المكررة بالجدول بدون اى مجهود
فقط نستدعى الكود ليقوم بعمل اللازم
و قد وضعت الكود فى وحدة نمطية لاستدعائها من اى نموذج
و الكود يقارن الحقول بكل سجل ( مع استبعاد حقول الترقيم التلقائى ان وجدت )
و يحذف السجل اذا تطابقت جميع الحقول
وضعت الشرح بالكود
طريقة الاستخدام
1- افتح وحدة نمطية جديدة و ضع بها هذا الكود
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 Function2- احفظ الوحدة النمطية بأى اسم
3- ضع هذا الكود فى زر حذف المكررات بالنموذج
DeleteDuplicateRecords ("t1")حيث t1 هو اسم الجدول المراد حذف المكررات منه
اتمنى ان يستفيد منه الجميع و الله الموفق
لا تنسونا من صالح دعائكم
