مطلوب تعديل على معادلة مضافة للاستاذ ياسر خليل

[صلاح الصغير]

الملف المرفق به معادلة مضافة للاستاذ ياسر خليل

و هى تقوم بنفس عمل المعادلة concatenate  و لكن بطريق سهلة و اسرع

و المطلوب هو تنفيذ هذه المعادلة و لكن بشرط كما بالشكل  بورقة 1

MultiCat UDF Function.rar

[عادل حنفي]

اخي

وبعد اذن الاخ الحبيبي ياسر

قمت بترتيب الشيت وعملت رؤوس للاعمدة يمكنك تغير اسمائها فيما عدا العامود الثاني

لانه سيرحل له كل كود جديد وغير مكرر لمجرد كتابته في العامود4 ومن ثم عمل مدي يتجدد باستمرار 

وما عليك الا اختيار الكود من عامود 8 فقط وسيتم عمل المطلوب

عموما جرب الملف

MultiCat UDF Function.rar

[صلاح الصغير]

ا / عادل شكرا جزيلا عمل رائع

و لكن يوجد خطأ بسيط و هو عند سحب كود معين يقوم بملاء البيانات تلقائى بالخطأ

 

MultiCat UDF Function2.rar

تم تعديل يونيو 3, 2016 بواسطه صلاح الصغير
تم رفع ملف خطأ

[عادل حنفي]

 

 

اخي صلاح

تمام الحمد لله ضع فقط Exit sub في الكود في منتصف الكود تقريبا وقبل السطر التالي

    
End if
If Target.Column = 8 And Target.Row > 3 And Target <> "" Then

 

ليكون الكود بالشكل التالي ولو فيه اي شيئ اخبرني

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Column = 4 And Target.Row > 3 And Target <> "" Then
        If Range("B4") = "" Then
            m = 4
        Else
            m = Range("B3").End(xlDown).Row
            n = Target.Row
        End If
        v = Application.WorksheetFunction.CountIf(Range("B4:B" & m), Target.Text)
        If v = 0 Then
            With Columns(2).Rows(500).End(xlUp)
                .Offset(1, 0) = Target
            End With
            m = Range("B3").End(xlDown).Row
            s = Range("B4").Address
            ss = Cells(m, 2).Address
            ActiveWorkbook.Names.Add Name:="Rng", RefersTo:="=" & ActiveSheet.Name & "!" & Range(s, ss).Address
        End If
        Exit Sub
       End If
    If Target.Column = 8 And Target.Row > 3 And Target <> "" Then
        If Selection.Columns.Count > 1 Then Exit Sub
        Cells(Target.Row, Target.Column + 1) = ""
        m = Range("D3").End(xlDown).Row
        For i = 4 To m
            If Cells(i, 4) = Target Then
                If Cells(Target.Row, Target.Column + 1) = "" Then    'or i < m Then
                    Cells(Target.Row, Target.Column + 1) = Cells(i, 5)
                Else
                    Cells(Target.Row, Target.Column + 1) = Cells(Target.Row, Target.Column + 1) & " " & "¡" & " " & Cells(i, 5)
                End If
            End If
        Next
    End If

 

[صلاح الصغير]

الكود توقف عن العمل تماما

 

تم تعديل يونيو 3, 2016 بواسطه صلاح الصغير

[عادل حنفي]

عذرا اخي صلاح

ضعها قبل الـ End if التي قبلها مباشرة

وانا معاك

ملحوظة

تم تعديل الكود السابق وهو الان ليس به مشكلة

[صلاح الصغير]

تمام ا عادل

بارك الله فيك 

يبقى تعديل بسيط و هو تحديث العمود b بمعنى عندما قمت بحذف كود لم يحذف من العمود b   rng

[عادل حنفي]

     

    طب استسمحك تتركه لي الآن وسوف اكمله لك في اقرب وقت ان شاء الله

[صلاح الصغير]

اشكرك شكرا جزيلا

و بارك الله فيك

فى انتظارك

[عادل حنفي]

جرب الملف تم التعديل

MultiCat UDF Function2.rar

[صلاح الصغير]

سلمت يداك

بجد عمل احترافى على اعلى مستوى

[ياسر خليل أبو البراء]

بارك الله فيك أخي الحبيب عادل حنفي

اسمح لي بوضع حل آخر إثراءً للموضوع

إليك دالة معرفة توضع في موديول عادي ..

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)
    Dim I As Long, J As Long
    Dim Result As String
    
    For I = 1 To LookupRange.Columns(1).Cells.Count
        If LookupRange.Cells(I, 1) = Lookupvalue Then
            For J = 1 To I - 1
                If LookupRange.Cells(J, 1) = Lookupvalue Then
                    If LookupRange.Cells(J, ColumnNumber) = LookupRange.Cells(I, ColumnNumber) Then
                        GoTo Skip
                    End If
                End If
            Next J
            Result = Result & " " & LookupRange.Cells(I, ColumnNumber) & " ، "
Skip:
        End If
    Next I
    MultipleLookupNoRept = Trim(Left(Result, Len(Result) - 3))
End Function

لاستخدام الدالة طبقاً لآخر ملف أرفقه أخونا عادل حنفي

ضع المعادلة التالية في الخلية I4 ثم قم بسحبها

=MultipleLookupNoRept(H4,$D$4:$E$18,2)

حيث يمثل البارامتر الأول خلية البحث والثاني نطاق البحث والثالث رقم العمود في نطاق البحث

تقبل تحياتي وكل عام وأنت بخير

 

[صلاح الصغير]

يا اخى و الله طول عمرك برنس

 

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

كله بفضل الله وحده أخي الكريم صلاح ، والشكر موصول لأخونا ومعلمنا القدير عادل حنفي بارك الله فيه

وكل عام وأنتم بخير