زيادة عدد التكرارات وحذف المكرر بشرط

[أبو عبد الله _]

السلام عليكم

مطلوب في هذا الملف كودين 

الأول كود في حدث ورقة العمل ( يعمل تلقائي) عند كتابة اسم او كود الموظف في العمود B ان يتم زيادة اخر قيمة مقابلة للكود  في عمود التكرارات E بالقيمة (واحد) 1 بغض النظر عن عدد التكرارات في العمود B 

الثاني كود مرتبط بزر 

يقوم بحذف الصفوف بناءا على القيم المكررة في العمود B مع الاحتفاظ باكبر واقل قيمة تكرار مثلا لو كود الموظف او الاسم مسجل له في العمود E تكرارات ١ و ٢ و ٣ و ٤ و ٥ يقوم بحذف ٢ و ٣ و ٤ 

لو اسم مسجل له ١ و٢ و ٣ يقوم بحذف ٢ 

 

 

 

حذف المكرر بشرط.xlsx

[أبوعيد]

وعليكم السلام

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

حذف المكرر معدل.xlsx

[أبو عبد الله _]

شكرا لحضرتك - واشكر اهتمامك 

أنا أعلم المعادلة بفضل الله ثم بفضل حلول الاساتذة أمثالكم

لكن أرغب في الأكواد نظرا لكثرة البيانات ( أولا )

ثانيا : عند حذف التكرارات في المنتصف سوف يؤثر على العدد

[محمد هشام.]

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

بالنسبة لطلبك الاول يمكنك استخدام الكود التالي 

 

Private Sub Worksheet_Change(ByVal Target As Range)
IRow = Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row
Dim r As Range:         Set r = Range("B2:B" & IRow)
Dim Arr() As Variant:    Arr = r.Value2
Dim Cpt() As Variant:   ReDim Cpt(1 To UBound(Arr), 1 To 1)
On Error Resume Next
 Application.EnableEvents = False
If Target.Column = 2 And Target.Row >= 2 Then
Select Case LCase(Target.Value)
 Case Is <> ""
With CreateObject("Scripting.DictionAry")
For i = 1 To UBound(Arr)
If Arr(i, 1) > 0 Then
 If Not .Exists(Arr(i, 1)) Then
        .Add Arr(i, 1), 1
        Cpt(i, 1) = .Item(Arr(i, 1))
Else
    .Item(Arr(i, 1)) = .Item(Arr(i, 1)) + 1
        Cpt(i, 1) = .Item(Arr(i, 1))
        End If
    End If
Next i
        r.Offset(, 3).Value2 = Cpt
          End With
        Case Is >= 0
        Me.Cells(Target.Row, 5) = Empty
      End Select
    End If
On Error GoTo 0
Application.EnableEvents = True
End Sub

 

في 13‏/3‏/2024 at 02:30, أبو عبد الله _ said:

لو اسم مسجل له ١ و٢ و ٣ يقوم بحذف ٢ 

بالنسبة للطلب الثاني ربما يجب عليك التوضيح اكثر هل تقصد عند تواجد اقل من 4 تكرارات يتم حدف اكبر قيمة فقط والاحتفاظ بالباقي او مادا 

 

حذف المكرر بشرط.xlsm

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

[أبو عبد الله _]

50 دقائق مضت, محمد هشام. said:

للطلب الثاني ربما يجب عليك التوضيح اكثر هل تقصد عند تواجد اقل من 4 تكرارات يتم حدف اكبر قيمة فقط والاحتفاظ بالباقي او مادا

 

في حالة وجود تكرارات يحتفظ بالاول والاخير وبحذف غير ذلك 

[محمد هشام.]

ادن ما هي النتيجة المتوقعة في حالة وجود نفس القيمة مكررة مرتين  فقط  او 3 

[محمد هشام.]

11 ساعات مضت, أبو عبد الله _ said:

في حالة وجود تكرارات يحتفظ بالاول والاخير وبحذف غير ذلك

 

Sub Delete_duplicate_condition()
Dim I As Integer, Cpt As String
Dim A As Integer, b As Integer

Dim WS As Worksheet: Set WS = Sheets("Sheet1")

lr = WS.Columns("B:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

For I = lr To 2 Step -1
    Cpt = Range("B" & I).Value
    
    A = Application.WorksheetFunction.MaxIfs(Range("E:E"), Range("B:B"), Cpt)
    
    b = Application.WorksheetFunction.MinIfs(Range("E:E"), Range("B:B"), Cpt)
    
    If Range("E" & I).Value <> A And Range("E" & I).Value <> b Then
        Range("B" & I & ":E" & I).Delete
    End If
    
    If Range("b" & I) = "" And Range("E" & I) = "" Then Range("B" & I & ":E" & I).Delete
    
Next I
End Sub

 

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