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

[الساحر NeT]

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

الاستاذة الكرام 

عندي كود ترحيل البيانات 

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

الشيت المراد التعديل عليه بااسم test مشروح فيه المطلوب 

ويوجد شيت اخر بااسم أصناف يوجد به المطلوب لكني ماعرف اعمله 

اصنافform - .rar test.rar

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

هذا الكود لا يدرج لك المكرر

Sub Tarhil()
  Dim i!, Ro!
  Dim A As Worksheet, E As Worksheet
  Dim RgA As Range
  Dim DIC_C As Object, dIC_j As Object
Application.ScreenUpdating = False
  Set E = Worksheets("EZN")
  Set A = Worksheets("ALL")
  Set RgA = A.Range("A1").CurrentRegion.Offset(1)
  RgA.Clear
  
  Ro = E.Cells(Rows.Count, 3).End(3).Row
  If Ro < 5 Then GoTo End_Me
  
Set DIC_C = CreateObject("Scripting.Dictionary")
Set dIC_j = CreateObject("Scripting.Dictionary")
    For i = 5 To Ro
     If E.Cells(i, 3) <> vbNullString Then
      DIC_C(E.Cells(i, 3)) = E.Cells(i, 6)
     End If
     If E.Cells(i, 13) <> vbNullString Then
       dIC_j(E.Cells(i, 13)) = E.Cells(i, 10)
     End If
    Next
With A.Cells(2, 1).Resize(DIC_C.Count)
  .Value = Application.Transpose(DIC_C.Items)
  .Offset(, 1) = Application.Transpose(DIC_C.keys)
  .Offset(, 2) = Application.Transpose(dIC_j.Items)
  .Offset(, 3) = Application.Transpose(dIC_j.keys)
End With
Ro = A.Range("a1").CurrentRegion.Rows.Count
With A.Range("a1").CurrentRegion.Offset(1).Resize(Ro - 1)
  .Borders.LineStyle = 1
  .Interior.ColorIndex = 35
  .Font.Size = 14
  .Font.Bold = True
  .InsertIndent 1
End With
End_Me:
Set DIC_C = Nothing: Set dIC_j = Nothing
Set A = Nothing: Set E = Nothing
Set RgA = Nothing
Application.ScreenUpdating = True

End Sub

الملف مرفق

 

Tel_Test.xlsm

[الساحر NeT]

لا أعلم ماذا أقول لك استاذي الفاضل 

لك كل الشكر والتقدير والاحترام 

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

شكرا لحضرتك