عدم تكرار البيانات في عمود

[حسين إبن محمد]

السلام عليكم يا اهل الخير والكرم

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

الملف المرفق عملت فيه عدم تكرار البيانات في عمود a

وتمت العملية بنجاح ولكن فعاله فقط عند الادخال

اما اذا نسخت ولصقت البيانات يتم وضعها عادي وهي مكررة شالحل

https://1drv.ms/x/c/e0a2b3b76351a8a0/EZiXVcE0SVdJiME8JsYA-hABR_yTVthuP3DIXk96EJMPrQ?e=FNnSZx

 

الملف في الرابط

no duplicate.xlsx

[حسين إبن محمد]

استخدمت

Data validation 

 

[محمد هشام.]

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

هل ترغب بإستخدام الأكواد ؟

ادا كان هدا يناسبك ضع هدا في حدث الورقة 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Cell As Range, tmp As Long
    On Error GoTo CleanExit
    Application.EnableEvents = False
    If Not Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) Is Nothing Then
        For Each Cell In Intersect(Target, Me.Range("A2:A" & Me.Rows.Count))
            If Trim(Cell.Value) <> "" Then
                tmp = Application.WorksheetFunction.CountIf(Me.Range("A:A"), Cell.Value)
                If tmp > 1 Then
                    Cell.ClearContents
                End If
            End If
        Next Cell
    End If

CleanExit:
    Application.EnableEvents = True
End Sub

 

تم تعديل منذ 6 ساعات بواسطه محمد هشام.

[عبدالله بشير عبدالله]

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

جرب الملف يتم الحدف عند الادخال او عند اللصق

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngChanged As Range
    Dim cell As Range
    Dim dict As Object
    Dim lastRow As Long
    Dim ws As Worksheet
    
    Set ws = Me
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set rngChanged = Intersect(Target, ws.Range("A1:A" & lastRow))
    
    If rngChanged Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each cell In ws.Range("A1:A" & lastRow)
        If Not Intersect(cell, rngChanged) Is Nothing Then GoTo NextCell
        If Not IsEmpty(cell.Value) Then
            dict.Add CStr(cell.Value), 1
        End If
NextCell:
    Next cell
    
    For Each cell In rngChanged
        If Not IsEmpty(cell.Value) Then
            If dict.exists(CStr(cell.Value)) Then
                Application.Undo
               ' MsgBox "القيمة '" & cell.Value & "' موجودة مسبقاً!", vbExclamation, "تنبيه"
                Exit For
            Else
                dict.Add CStr(cell.Value), 1
            End If
        End If
    Next cell
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

no duplicate.xlsb

[محمد هشام.]

إثراءا للموضوع يمكنك توسيع  منع التكرار على عدة أعمدة مثلا  A - C - E

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, OnRng As Range, Cell As Range
    Dim ColArr As Variant, tmp As Long

    On Error GoTo CleanExit
    Application.EnableEvents = False

   ColArr = Array("A", "C", "E")
'    ColArr = Array("A")
    
    For i = LBound(ColArr) To UBound(ColArr)
        If Not Intersect(Target, Me.Range(ColArr(i) & "2:" & ColArr(i) & Me.Rows.Count)) Is Nothing Then
            Set OnRng = Me.Columns(ColArr(i))
            For Each Cell In Intersect(Target, OnRng)
                If Trim(Cell.Value) <> "" Then
                    tmp = Application.WorksheetFunction.CountIf(OnRng, Cell.Value)
                    If tmp > 1 Then
                        Cell.ClearContents
                    End If
                End If
            Next Cell
        End If
    Next i

CleanExit:
    Application.EnableEvents = True
End Sub

 

[حسين إبن محمد]

انتم محترفون ما شاء الله عليكم كلكم ايجاباتكم جدا مجدية اشكركم 

يا رب يحقق كل امنيانتكم