قائمة بأسماء الطلاب مرتبة أبجدياً وغير مكررة مجمعة من عدة شيتات

[ياسر أحمد الشيخ]

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

أريد عمل قائمة بأسماء الطلاب مرتبة أبجدياً وغير مكررة مجمعة من عدة شيتات (class1-class2-class3-class4-class5)

الرجاء استخدام الكود لعمل ذلك

ملحوطة : هى ليست Listbox او Combobox وإنما أريدها قائمة مكتوبة فى نطاق خلايا أكسل (مثلاً فى النطاق b3:b50)

أرجو الافادة

Data.rar

تم تعديل أغسطس 4, 2016 بواسطه ياسر أحمد الشيخ

[عبدالسلام ابوالعوافي]

Data.rar

[سليم حاصبيا]

جرب هذا الملف

 

Data salim.rar

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

أخي الكريم جرب الكود التالي

Sub UniqueListFromMultipleSheets()
    Dim X, Y(), I&, J&, K&, WS As Worksheet
    ReDim Y(1 To Rows.Count, 1 To 1)
    
    With CreateObject("Scripting.Dictionary")
    
        .CompareMode = 1
        
        For Each WS In ThisWorkbook.Worksheets(Array("Class1", "Class2", "Class3", "Class4", "Class5"))
            X = WS.Range("B3:B" & WS.Cells(Rows.Count, "B").End(xlUp).Row).Value
            For I = 1 To UBound(X)
                If Len(X(I, 1)) Then
                    If Not .Exists(X(I, 1)) Then
                        J = J + 1
                        .Item(X(I, 1)) = J
                        Y(J, 1) = X(I, 1)
                    End If
                End If
            Next I
        Next WS
        
    End With

    With Sheets("Report")
        .Range("C3").Resize(J, 1).Value = Y()
    End With
End Sub

ستظهر القائمة في الخلية C3 في ورقة العمل Report >> أو إذا أردت في الخلية B3 قم بإزالة الجدول وجعل النطاق نطاق عادي ثم غير المرجع في الكود

تقبل تحياتي

 

[ياسر أحمد الشيخ]

شكرا لكم اخوانى على الردود

ولكن أنا أفضل كود الأخ الكريم عبدالسلام ابوالعوافي

وذلك لأن الكود الخاص به مختصر جداً وهذا ما أريده ، بس هناك تعديلات عايز أعملها على الكود:

1- أسماء الشيتات مختلفة وليست مرقمة كما بالملف class1 ، ارجو الغاء الاعتماد على الأرقام فى اسم الشيت 

2- أريد زيادة نطاق الأسماء حيث أن الأسماء عندى تجدها 100 فى class وممكن تجدها 150 فى class آخر وهكذا

3-أريد عمل ترقيم تلقائى بجوار الأسماء

شكرا مقدماً

تم تعديل أغسطس 7, 2016 بواسطه ياسر أحمد الشيخ

[ياسر أحمد الشيخ]

للرفع........للرفع

[عبدالسلام ابوالعوافي]

جرب

Sub Awafi()
Dim i, ii, iii As Integer, sh As Worksheet
    Sheet6.Range("b:b").ClearContents
    iii = 3
    For Each sh In Sheets
        If Not sh.Name = "Report" Then
            For ii = 3 To 200
                If Len(sh.Cells(ii, 2)) = 0 Then Exit For
                If Application.WorksheetFunction.CountIf(Sheet6.Range("b3:b" & iii), _
                    sh.Cells(ii, 2)) = 0 Then _
                    Sheet6.Cells(iii, 2) = sh.Cells(ii, 2): Sheet6.Cells(iii, 1) = iii - 2 _
                    : iii = iii + 1
            Next ii
        End If
    Next sh
    ActiveWorkbook.Worksheets("Report").Sort.Apply
End Sub

 

مع العلم اخي العزيز ياسر .. مانقدمه في الغالب هو فكرة الحل وليس الحل المتكامل .. فيمكنك اضافة اوتعديل على الاكواد بما يناسب عملك .. 

بالتوفيق

تم تعديل أغسطس 9, 2016 بواسطه عبدالسلام ابوالعوافي

[ياسر أحمد الشيخ]

شكرا لك أخىعبدالسلام ابوالعوافي

شكرا لك أخى ياسر خليل أبو البراء

شكرا لك أخى سليم حاصبيا

حلول أكثر من رائعة

تمت الاجابة

 

شكرا لك أخىعبدالسلام ابوالعوافي

شكرا لك أخى ياسر خليل أبو البراء

شكرا لك أخى سليم حاصبيا

حلول أكثر من رائعة

تمت الاجابة