saad abed قام بنشر مارس 30, 2020 مشاركة قام بنشر مارس 30, 2020 السلام عليكم كيف احصل على قيم فريده من ثلاث صفحات صفحه1-2-3 القيم المطلوبه اسم البند ولكن بشرط اسم المورد اى قيم التى تقابل اسم المورد من ثلاث صفحات قيم فريده بشرط.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مارس 30, 2020 مشاركة قام بنشر مارس 30, 2020 جرب هذا الماكرو 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 3 رابط هذا التعليق شارك More sharing options...
saad abed قام بنشر مارس 30, 2020 الكاتب مشاركة قام بنشر مارس 30, 2020 استاذ سليم اشكرك كل الشكر هذا هو المطلوب بالضبط جزاك الله خيرا رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر مارس 31, 2020 أفضل إجابة مشاركة قام بنشر مارس 31, 2020 تعديل بسيط على الماكرو ليظهر اسماء الشيتات 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 2 رابط هذا التعليق شارك More sharing options...
saad abed قام بنشر مارس 31, 2020 الكاتب مشاركة قام بنشر مارس 31, 2020 اخى سليم انت مبدع استاذى اشكرك على الاضافة (ظهور اسماء الشيتات ) جزاك الله خيرا 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.