إجمالي مرات مشاهدة الصفحة

الثلاثاء، 6 سبتمبر 2016

تقسيم أو شطر قائمة واحدة إلى قائمتين بالتساوي Split List In Two Lists Equally

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




أقدم لكم موضوع جديد ألا وهو تقسيم أو شطر قائمة واحدة إلى قائمتين بالتساوي

بفرض أن لديك قائمة بأسماء التلاميذ وليكن عدد التلاميذ 23 وتريد تقسيم القائمة أي شطرها إلى نصفين .. في الشطر الأيمن 12 طالب وفي الأيسر 11 طالب (الكود مرن ويتعامل مع أي عدد من الأسماء أو البيانات)

ترى هل يمكن عمل ذلك بسهولة؟ >> نعم جرب الكود التالي لترى بنفسك

إليكم الكود ... يقوم الكود بتقسيم القائمة إلى شطرين بالبيانات الملحقة بها وتظهر النتائج في ورقة العمل الثانية Sheet2

Sub SplitList()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    'تعريف المتغيرات
    Dim shSource As Worksheet, shTarget As Worksheet
    Dim rList As Range, rListA As Range, rListB As Range
    Dim hCount As Long, tCount As Long
    
    'عدد أعمدة النطاق المراد عمل إنشطار له
    Const colNum As Integer = 3
    
    'تعيين ورقة العمل المصدر التي تحتوي القائمة الرئيسية وورقة العمل الهدف
    Set shSource = Sheets("Sheet1")
    Set shTarget = Sheets("Sheet2")
    
    'تعيين النطاق الذي يحتوي على القائمة المراد شطرها
    Set rList = shSource.Range("A6:A" & shSource.Cells(Rows.Count, "A").End(xlUp).Row)
    
    'تعيين بداية النطاق للشطر الأول من القائمة
    Set rListA = shTarget.Range("A4")
    
    'تعيين بداية النطاق للشطر الثاني من القائمة
    Set rListB = rListA.Offset(, colNum)
    
    'تعيين قيمة المتغير ليساوي عدد خلايا النطاق المصدر
    tCount = rList.Cells.Count
    
    'تعيين قيمة للمتغير ليساوي تقريب قيمة قسمة المتغير السابق ÷ 2
    hCount = Application.RoundUp(tCount / 2, 0)

    'مسح النطاق الذي ستظهر فيه النتائج للشطر الأول والشطر الثاني
    shTarget.Range("A3").CurrentRegion.Offset(1).ClearContents
    
    'وضع نتائج الشطر الأول
    rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value
    
    'وضع نتائج الشطر الثاني
    rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value
    
    MsgBox "Done ..." & vbNewLine & "Best Regards" & Chr(10) & "YasserKhalil", 64
End Sub

إعداد / ياسر خليل أبو البراء

هناك 4 تعليقات:

  1. لله درك اختصرت الصعاب وأتيت بالسهل الممتنع بورك فيك

    ردحذف
  2. أخي العزيز أبو محمد الكبير .. بارك الله فيك ومشكور على كلماتك الطيبة ومرورك الندي بالمدونة

    ردحذف
  3. كود رائع كما عودتنا ..ويا سلام لو اضيف له كود للابجدة ..وآخر لتحديد نطاق الطباعة على قدر البيانات تماما ...ولكم جزيل الشكر استاذي الفاضل

    ردحذف
  4. بارك الله فيك أخي الكريم أحمد
    إن شاء الله نحاول تلبية طلبك .. وإن كنت أفضل أن يكون لكل موضوع هدف واحد فقط يتم التركيز عليه

    ردحذف