ازالة الاكواد المكررة بشرط معين

[figo82eg]

ارجو المساعدة حيث لدى لملف اكسل به عدد عملاء يتعدى 200 الف عميل وعندى مشكلة فى تكرار اكواد هذه العملاء نتيجة تكرار تاريخ التركيب للعملاء بمعنى :

1- يمكن ان يتكرر الكود اكثر من مرة حين يتم زيارة العميل بأكثر من تاريخ

2- ممكن ان يكون تاريخ التركيب للسجل مرة خالى وممكن ان يكون به تاريخ زيارة

وعند عمل ازالة للأكواد المكررة من Remove Duplicates يتم حذف الاكواد المكررة بصورة عشوائية  

ما اريده هو حذف الاكواد المكرره بشرط ان ما يتبقى بعد الحذف هو كود اخر تاريخ تركيب او زيارة للكود

مرفق مثال بسيط للتطبيق

عملاء مكررين.XLSX

تم تعديل مايو 9 بواسطه figo82eg

[محمد هشام.]

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

جرب هل هدا ما تقصده 

Sub test()
    Dim WS As Worksheet, lastRow As Long, i As Long, dict As Object
    Dim cnt As String, dateStr As String, tmps As Date, maxDate As Date, tbl As Long

    Set WS = Sheets("Sheet1")
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    Set dict = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    For i = 2 To lastRow
    
        cnt = Trim(WS.Cells(i, 1).Value)
        dateStr = Trim(WS.Cells(i, 2).Value)
        If cnt <> "" And IsDate(dateStr) Then
            tmps = CDate(dateStr)
            If Not dict.exists(cnt) Then
                dict.Add cnt, Array(tmps, i)
            ElseIf tmps > dict(cnt)(0) Then
                dict(cnt) = Array(tmps, i)
            End If
        End If
        
            Next i

    For i = lastRow To 2 Step -1
        cnt = Trim(WS.Cells(i, 1).Value)
        If dict.exists(cnt) Then
            tbl = dict(cnt)(1)
            If i <> tbl Then WS.Range("A" & i & ":C" & i).Delete Shift:=xlUp  ' OR WS.Rows(i).Delete
        End If
    Next i
    
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    End Sub

 

تم تعديل مايو 10 بواسطه محمد هشام.

[محمد هشام.]

جرب هدا

 

عملاء مكررين v2.xlsb

تم تعديل مايو 10 بواسطه محمد هشام.

[figo82eg]

جزاك الله خيرا وجعل علمك فى ميزان حسناتك استاذى الكريم