استدعاء قيم فريده من ثلاث صفحات بشرط(معادلات او كود)

[saad abed]

السلام عليكم

كيف احصل على قيم فريده من ثلاث صفحات

صفحه1-2-3 القيم المطلوبه اسم البند

ولكن بشرط اسم المورد اى قيم التى تقابل اسم المورد من ثلاث صفحات

قيم فريده بشرط.xlsx

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

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

Option Explicit

Sub Uniq_items()
  Dim R As Worksheet, Sw As Worksheet
  Dim Nme$, Rg As Range
  Dim cop_rg As Range
  Dim dic As Object, I%, m%
  
  Set R = Sheets("report")
  Set dic = CreateObject("Scripting.Dictionary")
  Set cop_rg = R.Range("B4").CurrentRegion
Nme = R.Range("C2")
If cop_rg.Rows.Count > 1 Then
cop_rg.Offset(1).ClearContents
End If
m = 5
For Each Sw In Sheets
 If Sw.Name <> R.Name Then
  Set Rg = Sw.Range("G5", Sw.Range("G4").End(4))
  For I = 1 To Rg.Rows.Count
   If Rg.Cells(I).Offset(, 2) = Nme Then
    dic(Rg.Cells(I).Value) = _
    Rg.Cells(I).Offset(, 2).Value
   End If
 Next
 If dic.Count = 0 Then GoTo Next_Sheet
    With R.Cells(m, 2).Resize(dic.Count)
     .Value = Application.Transpose(dic.keys)
     .Offset(, 1) = Application.Transpose(dic.items)
      m = m + dic.Count: dic.RemoveAll
    End With
 End If
Next_Sheet:
 Next Sw
End Sub

الملف مرفق

Unique_item.xlsm

[saad abed]

استاذ سليم 

اشكرك كل الشكر

هذا هو المطلوب بالضبط

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

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

تعديل بسيط على الماكرو ليظهر اسماء الشيتات

Sub Uniq_items_With_Sh_Names()
  Dim R As Worksheet, Sw As Worksheet
  Dim Nme$, Rg As Range
  Dim cop_rg As Range
  Dim dic As Object, I%, m%
  Dim arr(), ky, t%
  Set R = Sheets("report")
  Set dic = CreateObject("Scripting.Dictionary")
  Set cop_rg = Range("B4").CurrentRegion
Nme = R.Range("C2")
If cop_rg.Rows.Count > 1 Then
cop_rg.Offset(1).ClearContents
End If
m = 5
For Each Sw In Sheets
 If Sw.Name <> R.Name Then
  Set Rg = Sw.Range("G5", Sw.Range("G4").End(4))
  For I = 1 To Rg.Rows.Count
   If Rg.Cells(I).Offset(, 2) = Nme Then
    dic(Rg.Cells(I).Value) = _
    Rg.Cells(I).Offset(, 2).Value
   End If
  Next
 If dic.Count = 0 Then GoTo Next_Sheet
  For Each ky In dic.keys
    ReDim Preserve arr(t)
      If t = 0 Then
        arr(t) = dic(ky) & ": Sheet " & Sw.Name
      Else
        arr(t) = dic(ky)
      End If
    t = t + 1
   Next

    With R.Cells(m, 2).Resize(dic.Count)
     .Value = Application.Transpose(dic.keys)
     .Offset(, 1) = Application.Transpose(arr)
      m = m + dic.Count: dic.RemoveAll: Erase arr: t = 0
    End With
 End If
Next_Sheet:
 Next Sw
End Sub

الملف من جديد

Unique_item_1.xlsm

[saad abed]

اخى سليم 

انت مبدع استاذى 

اشكرك على الاضافة (ظهور اسماء الشيتات )

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