تقسيم قائمة الأسماء الى عدة قوائم مكونة من 10 أسماء متسلسلة

[ربيع القيسي]

السلام عليكم وعلى كل الاخوة في الاكسلوالمواضيع الاخرى

لدي قائمة من الاسماء في ورقة اكسل متسلسلة من 1 الى 200 اسم شخص اريد ان اقوم بتقسيم هذه الاسماء الى كل 10 اسماء متسلسلة في قوائم اكسل اخرى او في برنامج المراسلات ولكم كل التقدير .... عنوان مخالف تم تعديل عنوان المشاركة ليعبر عن طلبك

ربيع القيسي

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

وهل من المفروض على من سيقوم بالمساعدة ان ينشأ لك ملفاً بما تريد؟ ام عليك رفع الملف بنفسك

على كل حال اليك هذا النموذج يحتوي على 2 ماكرو  واحد للقوائم المنسدلة والاحر لادراج الاسماء 10 : 10

الماكرو ديناميكي (اي انه يحصي كل الاسماء مهما كان عددها)
(كل مجموعة مرتية ابجدياُ)

Option Explicit
Sub Get_data_val()
Const t = 10
Dim obj As Object
Dim lr%, i%, m%, k%, Cnt%
Dim arr
Dim My_rg As Range
If ActiveSheet.Name <> "Sheet1" Then Exit Sub
k = 3
lr = Cells(Rows.Count, 1).End(3).Row
 Set obj = CreateObject("System.Collections.Arraylist")
 For i = 2 To lr Step t
   Set My_rg = Cells(i, 1).Resize(t)
   Cnt = Application.CountA(My_rg)
   Set My_rg = My_rg.Cells(1, 1).Resize(Cnt)
      Do Until m = Cnt
        obj.Add My_rg.Cells(m + 1, 1).Value
        m = m + 1
      Loop
      
      If obj.Count Then
       obj.Sort
        With Cells(2, k).Validation
       .Delete
       .Add 3, Formula1:=Join(obj.Toarray, ",")
       Cells(2, k) = obj(0)
    End With
      End If
   k = k + 1: m = 0
   obj.Clear

  Next i
End Sub
'++++++++++++++++++++++++++++++++++
Sub Get_By_10()
Const t = 10
Dim obj As Object
Dim lr%, i%, m%, k%, Cnt%
Dim My_rg As Range

If ActiveSheet.Name <> "Sheet1" Then Exit Sub
k = 3
lr = Cells(Rows.Count, 1).End(3).Row
 Set obj = CreateObject("System.Collections.Arraylist")
 Cells(5, 3).CurrentRegion.Offset(1).ClearContents
 For i = 2 To lr Step t
   Set My_rg = Cells(i, 1).Resize(t)
   Cnt = Application.CountA(My_rg)
   Set My_rg = My_rg.Cells(1, 1).Resize(Cnt)
      Do Until m = Cnt
        obj.Add My_rg.Cells(m + 1, 1).Value
        m = m + 1
      Loop
      
      If obj.Count Then
       obj.Sort
       Cells(5, k).Resize(obj.Count) = _
       Application.Transpose(obj.Toarray)
      End If
   k = k + 1: m = 0
   obj.Clear

   Next i
End Sub

الملف مرفق

Kaissi.xlsm