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

[ksaa]

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

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

------------------------

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

بمعنى لدي... عمود ( 1 ) يوجد فية اسم الشركة

عمود ( 2 ) فية رقم الفاتورة

اريد منع تكرار الاسم والرقم معا

* قد يتكرر الاسم اما رقم الفاتورة لا اعتقد خاصة لنفس الشركة

دمتم بخير وود جميعا

[سليم حاصبيا]

كان يجب رقع ملف للمعالجة

لكن اليك هذا النموذج الذي يمنع التكرار في العامودين الأول والثاني (النظاق الأخضر)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x%, RG As Range
x = Cells(Rows.Count, 1).End(3).Row
Set RG = Range("A1:B" & x)
Application.EnableEvents = False

If Not Intersect(Target, RG) Is Nothing And _
 Application.CountA(Range("A" & Target.Row).Resize(, 2)) = 2 Then
 RG.RemoveDuplicates Array(1, 2)
End If

Application.EnableEvents = True
End Sub

الملف مرفق

No_dups.xlsm

[ksaa]

السلام عليكم

الاستاذ سليم اعتذر لعدم ارفاق الملف

والف الف شكر لك اخي

انتم اساتذتنا ومنكم نتعلم ونستفيد والاعتذار عن تقصيرنا بعض الاوقات واجب علينا

دمت بصحة وسلامة وتوفيق من الله.

لاحظت انه يسمح السجل بمجرد ان انهي التسجيل

  هل يمكن ان يضلل الخلايا للتاكد من المطابقة ثم اقوم انا بمسحه او التعديل عليه

نسخة من No_dups.xlsm

[سليم حاصبيا]

هذا الماكرو يقوم بتجديد التكرار   باللون الاصفر (العامودين الاول والثاني)

Option Explicit
 'Excel VBA find duplicates with the scripting dictionary
  Rem Created By salim hasbaya On 21/2/2021
Sub Find_Dupl()
Dim D As Worksheet
Dim ar As Variant, Curt_rg As Range
Dim i As Long, Rg As Range
Dim ro%

Set D = Sheets("Data")
 
 Set Curt_rg = D.Range("B2").CurrentRegion
  ro = Curt_rg.Rows.Count
 If ro = 1 Then Exit Sub
 Set Curt_rg = Curt_rg.Offset(1).Resize(ro - 1)
 Curt_rg.Interior.ColorIndex = xlNone
ar = D.Cells(2, 2).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(ar, 1)
      If Not .Exists(ar(i, 1) & "*" & ar(i, 2)) Then
      .Item(ar(i, 1) & "*" & ar(i, 2)) = Empty
      Else
        If Rg Is Nothing Then
           Set Rg = D.Cells(i, 2).Resize(, 2)
        Else
          Set Rg = Union(Rg, D.Cells(i, 2).Resize(, 2))
        End If
      End If
    Next
End With
 If Not Rg Is Nothing Then
  Rg.Interior.ColorIndex = 6
  End If
  
End Sub

الملف مرفق

Ksaa.xlsm

[ksaa]

عجزت ان اجد ما يوفيك من كلمات الشكر

ولكن لم اعجز عن دعوة لك بظهر الغيب

اسأل الله لك التوفيق والعفو والعافية والمعافية فية دينك وبدنك

دمت سالماً  ودمت بخير

 

 

 

-------