معادلة لرفع التكرار وعدم ادراج بعض العناوين المستثناة

[خالد ابوعوف]

السلام عليكم - حياكم الله

ممكن معادلة لتصفية العناوين بدون تكرار  --- مع حذف بعض العناوين المستثناة 

كما موجود بالملف المرفق

معادلة لتصفية الاسماء عدا بعض الدرجات.xlsx

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

جرب هذا الماكرو

Option Explicit
Sub Unique_BY_Dictionary()
Rem ====>> Created By Salim Hasbaya On 30/8/2019
If ActiveSheet.Name <> "ورقة1" Then Exit Sub
Dim i%
Dim obj As Object
Range("D2", Range("D1").End(4)).ClearContents
Range("e2").ClearContents
Set obj = CreateObject("scripting.dictionary")
obj.CompareMode = 1
Dim last_ro: last_ro = Cells(Rows.Count, "B").End(3).Row
With obj
 For i = 2 To last_ro
    If Application.CountIf(Range("H2:H4"), Range("B" & i)) = 0 Then
    .Item(Range("B" & i).Value) = ""
    End If
Next
  Range("d2").Resize(.Count) = _
  Application.Transpose(.keys)
  Range("e2") = .Count
End With
End Sub

الملف مرفق

No_dup.xlsm

[خالد ابوعوف]

مشكور اخ سلي

جزيت خيرا

كود سهل وشغال 100 %

هل ممكن زيادة للموضوع

ممكن معادلة 

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

العامود الاصفر في صفحة Salim من هذا الملف 

 

No_dup _by_formula.xlsm

[خالد ابوعوف]

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