تحديد الاسماء المتكررة بين ورقتي عمل وليس فقط ضمن ورقة العمل

[رسول هادي]

السلام عليكم

ارجو ان يكون الجميع بخير وصحة وعافية . بخصوص تحديد الاسماء المتكررة في ورقة العمل نفسها فهو واضح . السؤال هل بالامكان تحديد التكرار بين الاسماء في ورقتي عمل ارجو تطبيق ذلك على الملف المرفق، مع فائق الشكر والتقدير

تكرار.xlsm

[أحمد يوسف]

وعليكم السلام أخى الكريم .... رجاءا من الجميع الإلتزام بتعليمات وقوانين المنتدى ,فقد نبهنا مئات المرات ان لا تقوم برفع وعرض مشاركة جديدة الا بعد التأكد ان طلبك لم تم مناقشته وتداوله مسبقا داخل المنتدى

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

تلوين خلية بجميع اوراق العمل اذا تكررت في اي ورقة عمل

وهذا موضوع ايضا اخر مختلف لعدم تكرار البيانات المدخلة فى كل صفحات الملف

عدم تكرار البيانات المدخلة في كل الشيتات

جزاك الله كل خير

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

جرب هذا الكود

Option Explicit
Sub Colorize_Dupicates()
  Dim Sh As Worksheet, A As Worksheet
  Dim Rg As Range, cel As Range, _
   Act_Rg As Range, F_rg As Range
  Dim Fadr$, Sadr$
  Dim D As Object
  Dim i%, X%, y%

Set Sh = ActiveSheet
Set Rg = Sh.Range("a1").CurrentRegion.Columns(1).Cells
X = Sh.Cells(Rows.Count, 1).End(3).Row
Sh.Range("C1:z" & X).Clear
Set D = CreateObject("Scripting.Dictionary")
Rg.Interior.ColorIndex = xlNone
 For Each A In Sheets
    A.Range("a1").CurrentRegion.Columns(1) _
    .Interior.ColorIndex = xlNone
    A.Range("C1:z100").Clear
 Next
 
 For Each cel In Rg
  For Each A In Sheets
   If A.Name <> Sh.Name Then

    Set Act_Rg = A.Range("a1").CurrentRegion.Columns(1)
     X = A.Cells(Rows.Count, 1).End(3).Row

     Set F_rg = Act_Rg.Find(cel, lookat:=1)
    If F_rg Is Nothing Then GoTo Next_A
      cel.Interior.ColorIndex = 6
      Fadr = F_rg.Address: Sadr = Fadr
       Do
          F_rg.Interior.ColorIndex = 6
          D(A.Name & " :Row (" & F_rg.Row & ")") = vbNullString
          Set F_rg = Act_Rg.FindNext(F_rg)
          Sadr = F_rg.Address
          If Sadr = Fadr Then Exit Do
       Loop
     
   End If
Next_A:
  Next A
If D.Count > 0 Then
  With cel.Offset(, 2).Resize(, D.Count)
      .Value = D.keys
      .Borders.LineStyle = 1
      .Interior.ColorIndex = 38
      .InsertIndent 1
  End With
  With cel.Offset(, 2 + D.Count)
      .Value = IIf(D.Count = 1, "1 Duplicate", D.Count & " Duplicates")
      .Borders.LineStyle = 1
      .Interior.ColorIndex = 6
      .InsertIndent 1
  End With
Else
 With cel.Offset(, 2)
   .Value = "No Duplicates"
   .Borders.LineStyle = 1
   .Interior.Color = vbGreen
   .InsertIndent 1
  End With
End If
   D.RemoveAll
 Next cel
End Sub

الملف مرفق

Count_Tekrars.xlsm

[رسول هادي]

شكرا على الجهود واعتذر لعدم الالتزام بقوانين المنتدى

[أحمد يوسف]

أستاذ رسول هادي

أين الضغط على الإعجاب لكل هذه الإجابات ؟!!!💙