مطلوب تحويل معادله الي CODE VBA

[hanykassem]

السلام عليكم 

اخوتنا الكرام

مطلوب تحويل هذه المعادل الي كود ويرجي توضيح تحويل اي معادله الي كود مع الشرح

=TEXTJOIN(", ",TRUE,UNIQUE(FILTER($B$4:$B$1200,$A$4:$A$1200=C3)))

وشكرا لكم جميعا

TEST CODE.xlsx

[أبومروان]

وعليكم السلام 

Function JoinUniqueValues(lookupValue As Variant, lookupRange As Range, returnRange As Range) As String
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long
    Dim result As String
    
    ' إنشاء قاموس لتخزين القيم الفريدة
    For i = 1 To lookupRange.Count
        If lookupRange.Cells(i, 1).Value = lookupValue Then
            If Not dict.exists(returnRange.Cells(i, 1).Value) Then
                dict.Add returnRange.Cells(i, 1).Value, Nothing
            End If
        End If
    Next i
    
    ' دمج القيم الفريدة باستخدام فاصلة
    result = Join(dict.keys, ", ")
    
    JoinUniqueValues = result
End Function

لاستخدام هذا الكود، قم بإضافته إلى وحدة VBA في Excel، ثم استخدم الدالة في ورقة العمل كالتالي:

 

=JoinUniqueValues(I3, $A$4:$A$1200, $B$4:$B$1200)

 

TEST CODE.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

بطريقة أخرى 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1")
    Dim n As Object: Set n = CreateObject("Scripting.Dictionary")
    Dim i As Long, ling As Long, lastRow As Long, tmp As String, kay As String, j As Variant
    
    If Not Intersect(Target, WS.Range("A4:B" & WS.Rows.Count)) Is Nothing Then
        Application.ScreenUpdating = False
        
        With WS
            ' مسح النتائج السابقة
            .Range("I3:J" & .Rows.Count).ClearContents
            
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            ling = 3 '  تحديد صف وضع النتائج
            
            ' بداية من الصف 4
            For i = 4 To lastRow
                tmp = .Cells(i, 1).value ' الحصول على القيمة من عمود A
                kay = .Cells(i, 2).value ' الحصول على القيمة من عمود B

                ' التأكد من أن القيم ليست فارغة
                If tmp <> "" And kay <> "" Then
                    If n.Exists(tmp) Then
                        n(tmp) = n(tmp) & ", " & kay
                    Else
                        n.Add tmp, kay
                    End If
                End If
            Next i
            
            For Each j In n.Keys
                .Cells(ling, 9).value = j ' القيم الفريدة في عمود I
                .Cells(ling, 10).value = n(j) ' القيم المرتبطة في عمود J
                ling = ling + 1
            Next j
            
            ' تعديل عرض العمود  ليتناسب مع المحتوى
            .Columns("J").AutoFit
        End With
        
        Application.ScreenUpdating = True
    End If
End Sub

 

TEST CODE.xlsb

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله تعالى وبركاته

اظافة الى ما تقضلو  به اساتذتنا الاكارم

 

TEST CODE1.xlsm

تم تعديل نوفمبر 12 بواسطه عبدالله بشير عبدالله