اذهب الي المحتوي
أوفيسنا

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


الردود الموصى بها

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

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

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

MultiCat UDF Function.rar

رابط هذا التعليق
شارك

اخي

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

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

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

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

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

MultiCat UDF Function.rar

  • Like 1
رابط هذا التعليق
شارك

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

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

 

MultiCat UDF Function2.rar

تم تعديل بواسطه صلاح الصغير
تم رفع ملف خطأ
رابط هذا التعليق
شارك

 

 

اخي صلاح

تمام الحمد لله ضع فقط 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 weeks later...

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

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

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

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)

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

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

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information