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

[sabah2023]

السلام عليكم

يوجد معادلة حاولت ان اعدل عليها ولكن لم احصل على النتيجة المطلوبة

وارفت ملف يتضمن النتائج المطلوبة

اتمنى ان اجد الحل لهذا الموضوع كما توعدنا

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

 

نقل الاسماء بدون تكرار بشروط.xlsx

تم تعديل نوفمبر 8, 2023 بواسطه sabah2023

[محي الدين ابو البشر]

عليكم السلام

إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا ....

Sub test()
    Dim a, w
    Dim T As String
    Dim i&
    a = Sheets("aaa").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            T = a(i, 2) & a(i, 3) & a(i, 4)
            If Not .exists(T) Then
                .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4), a(i, 1), a(i, 1) + IIf(a(i, 1) = 1, 199, 99))
            Else
                w = .Item(T): w(5) = w(4) + 99: .Item(T) = w
            End If
        Next
        Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2) + 2) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[sabah2023]

السلام عليكم

حياك الله

يوجد بعض الملاحظات بالملف المرفق  - ارجو المرور عليها 

جزيت خيرا

 

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

نقل الاسماء بدون تكرار بشروط - كود (1).xlsm

تم تعديل نوفمبر 9, 2023 بواسطه sabah2023

[محي الدين ابو البشر]

عليكم السلام

(اظهار الكودات بالخانات بالاخضر  على أساس ما محدد باللون الأصفر)

غير مفهوم

[sabah2023]

السلام عليكم 

الكود شغال بجلب اسماء المخازن وفروعها بشكل 100 %

الخانات باللون الاخضر المطلوب هو - اعزكم الله

اظهار التسلسلات بشكل تلقائي اثناء الضغط على زر التنفيذ على اساس التسلسلات باللفون الاصفر

وسوف اكتب التسلسلات (النتائج المطلوبة)  في خانات اللون الاخضر كمثال ، ويرحم والديك - لا تنسى شرح الكود لي

نقل الاسماء بدون تكرار بشروط - كود123.xlsm

تم تعديل نوفمبر 9, 2023 بواسطه sabah2023

[محمد هشام.]

كما ذكر الأخ @محي الدين ابو البشر من قبل

مازال طلبك الأخير غير واضح نهائيا .!!!!

[أ / محمد صالح]

استكمالا لجهود الزملاء الأعزاء

إذا كان لديك أوفيس 2021 أو 365 يمكنك وضع هذه المعادلة في I2

=UNIQUE($B$2:$D$16)

أو يمكنك تعديل الإجراء المقدم من أخينا @محي الدين ابو البشر إلى

Sub test()
Dim a, T As String, i&
a = Sheets("aaa").Cells(1).CurrentRegion
With CreateObject("scripting.dictionary")
    For i = 2 To UBound(a)
        T = a(i, 2) & a(i, 3) & a(i, 4)
        If Not .exists(T) Then
            .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4))
        End If
    Next i
    Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2)) = Application.Index(.items, 0, 0)
End With
End Sub

ولوضع كود لكل مادة في العمود الأول

يمكنك وضع هذه المعادلة في الخلية A2 مع سحبها لأسفل

=IFERROR(INDEX(M$2:M$8,MATCH(B2&C2&D2,J$2:J$8&K$2:K$8&L$2:L$8,0))-1+COUNTIFS(B$2:B2,B2,C$2:C2,C2,D$2:D2,D2),"")

بالتوفيق للجميع

[sabah2023]

جزيت خيرا

كل شيء تمام 100 %

تسلم

[أ / محمد صالح]

جميعا بإذن الله تعالى 

[محمد هشام.]

اليك حل اخر بعد اظافة معادلة الاخ محمد صالح 

Sub Test2()
Set d = CreateObject("Scripting.Dictionary")
  k = Range("b2:D" & [b65000].End(xlUp).Row)
  Dim Rng(): ReDim Rng(1 To UBound(k), 1 To UBound(k, 2))
  For i = LBound(k) To UBound(k)
    Réf = k(i, 1) & "|" & k(i, 2) & "|" & k(i, 3)
    If d.exists(Réf) Then
       lig = d(Réf)
Else
d(Réf) = d.Count + 5: lig = d.Count: Rng(lig, 1) = k(i, 1): Rng(lig, 2) = k(i, 2): Rng(lig, 3) = k(i, 3)
End If
    
 Next i
 
[j2].Resize(d.Count, UBound(Rng, 2)) = Rng
End Sub

 

نقل الاسماء بدون تكرار بشروط.xlsb

تم تعديل نوفمبر 10, 2023 بواسطه محمد هشام.

[sabah2023]

تمام 

تسلم