مطلوب تحويل معادله الي 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 بواسطه عبدالله بشير عبدالله

[hanykassem]

On 11/11/2024 at 6:39 PM, محمد هشام. said:

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

بطريقة أخرى 

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



الف شكر علي المجهود العظيم م/ محمد هشام 

1	a	S-K-01
1	b	S-K-02
1	c	S-K-03
1	a	S-K-03
2	X	S-K-05
2	Y	S-K-06
2	z	S-K-07
2	v	S-K-03
2	u	S-K-01
1	a	S-K-10


 "C" في هذا المثال يمكنيني اضافه العمود 
"K"واظهار الناتج في  عمود 

 

TEST CODE.xlsb 16.41 kB · 30 downloads

 

[محمد هشام.]

7 ساعات مضت, hanykassem said:

1	a	S-K-01
1	b	S-K-02
1	c	S-K-03
1	a	S-K-03
2	X	S-K-05
2	Y	S-K-06
2	z	S-K-07
2	v	S-K-03
2	u	S-K-01
1	a	S-K-10


 "C" في هذا المثال يمكنيني اضافه العمود 
"K"واظهار الناتج في  عمود 

نعم اخي  @hanykassem  نظرا للمثال المرفق هناك بعض الإحتمالات الواردة في حالة كان هناك تكرار لنفس القيم  كما هو موضح في الصورة أدناه   

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Dim i As Long, ling As Long, lastRow As Long, tmp As String, kayB As String, kayC As String, _
                                                             j As Variant, a As Object, r As Object

    Set a = CreateObject("Scripting.Dictionary"): Set r = CreateObject("Scripting.Dictionary")
    If Not Intersect(Target, WS.Range("A4:C" & WS.Rows.Count)) Is Nothing Then
        Application.ScreenUpdating = False

        With WS
            .Range("I3:K" & .Rows.Count).ClearContents

            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            ling = 3

            For i = 4 To lastRow
                tmp = .Cells(i, 1).value
                kayB = .Cells(i, 2).value
                kayC = .Cells(i, 3).value

                If tmp <> "" Then
                    If kayB <> "" Then a(tmp) = IIf(a.Exists(tmp), a(tmp) & " , " & kayB, kayB)
                    If kayC <> "" Then r(tmp) = IIf(r.Exists(tmp), r(tmp) & " , " & kayC, kayC)
                End If
            Next i

            For Each j In a.Keys
                .Cells(ling, 9).value = j
                .Cells(ling, 10).value = a(j)
                .Cells(ling, 11).value = r(j)
                ling = ling + 1
            Next j

            .Columns("j:K").AutoFit
        End With

        Application.ScreenUpdating = True
    End If
End Sub

لحدف التكرارات قم بتعديل الصف التالي 

If tmp <> "" Then
   If kayB <> "" Then a(tmp) = IIf(a.Exists(tmp), a(tmp) & " , " & kayB, kayB)
   If kayC <> "" Then r(tmp) = IIf(r.Exists(tmp), r(tmp) & " , " & kayC, kayC)
End If

إلى


If tmp <> "" Then
    If kayB <> "" Then If Not a.Exists(tmp) Then a.Add tmp, _
    kayB Else If InStr(1, a(tmp), kayB) = 0 Then a(tmp) = a(tmp) & " , " & kayB
            
    If kayC <> "" Then If Not r.Exists(tmp) Then r.Add tmp, _
    kayC Else If InStr(1, r(tmp), kayC) = 0 Then r(tmp) = r(tmp) & " , " & kayC
 End If

 

TEST CODE 2.xlsb