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

[Abuelkhasem]

السلام عليكم

المطلوب دالة تقوم بعد الارقام في ورقة اكسل و كتابتها في خلية واحدة و عدم كتابة المكرر الا مرة واحدة.

مثال موجود بالمرفق

 

مع خالص الشكرexample.rar

تم تعديل أبريل 28, 2015 بواسطه aakr

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

الأخ الكريم

يرجى تغيير اسمك للغة العربية لسهولة التواصل

إليك الملف التالي لعله يكون المطلوب

Sub UniqueValuesWithinRangeIntoOneCell()
    Dim Rng As Range, DN As Range, N As Long, SP As Variant
    Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each DN In Rng
            SP = Split(DN.Value, ",")
            For N = 0# To UBound(SP)
                .Item(SP(N)) = Empty
            Next N
        Next DN
        Range("D5").Value = Join(.Keys, ",")
    End With
End Sub

لا تنسى أن تحدد المشاركة كأفضل إجابة إذا أعجبتك

تقبل تحياتي

Unique Values Within Range Into One Cell.rar

[Abuelkhasem]

شكرا سيد ياسر على الرد.

لدي بعض الاسفسارات اذا مافيش مانع  :

1- كيف يمكنني ان اطبق هالكود على رينج محدد من الخلايا غير الموجود بالمثال. مثلا من B1 الى B10

2- هل بالامكان ان يكون الحساب بصورة مباشرة عند حدوث اي تغيير في البيانات بدون الضغط على زر الكود

 

و شكرا مجددا على تعاونك

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

أخي الكريم عند إرفاق ملف في الموضوع يراعى أن يكون مطابق للملف الأصلي

يمكن تطبيق الكود على أي نطاق

Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))

من خلال هذا السطر تم تعيين النطاق الذي بدايته A2 ونهايته أخر خلية بها بيانات في العمود الاول

إذا كان النطاق الخاص بك ثابت من B1:B10 يمكنك استبدال السطر السابق بهذا السطر

    Set Rng = Range("B1:B10")

أما بالنسبة لطلبك الثاني فهو ممكن ولكن يجب تحديد النطاق الذي إذا تغيرت أي قيمة فيه يبدأ تنفيذ الكود

يمكن مراجعة الرابط التالي بخصوص هذا الطلب

تقبل تحياتي

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

أخي الفاضل

إليك حل آخر باستخدام دالة معرفة UDF

Function UnQ(rng As Range) As String
    Dim Dn As Range, n As Long, Sp As Variant
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        For Each Dn In rng
            Sp = Split(Dn.Value, ",")
            For n = 0# To UBound(Sp)
                .Item(Sp(n)) = Empty
            Next n
        Next Dn
        UnQ = Join(.Keys, ",")
    End With
End Function

تقبل تحياتي

Unique Values Within Range Into One Cell.rar

[Abuelkhasem]

رحم الله والديك و زادك في علمك و نفعك و نفعنا به

 

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