اضافة على كود توزيع الطلاب

[قصي]

بسم الله الرحمن الرحيم

احبابنا في الخير

لاحظت في بعض الاكواد

بدايه فيها اكثر من رائعه وهي اننا نستطيع نقل الكود بسهوله منقطعة النظير مع تغيير المعطيات في اول الكود مثل هذه البدايه على سبيل المثال

Const StudentData As String = "بيانات الطلبة"
Const TopStudents As String = "الاوائل"

ادعو الله ان يوفقنا الى اضافة هذه الميزة على هذا الكود

الخاص بالعلامه عبد الله باقشير

Sub KH_START()
    On Error Resume Next
    Dim MyRang_1 As Range, MyRang_2 As Range, MyRang_Formats As Range
    Dim S As Integer, E As Integer, W As Integer, V As Integer, T As Integer, TT As Integer _
    , H As Integer, M As Integer, Y As Integer, Z As Integer, N As Integer, U As Integer _
    , R As Integer, C As Integer, CC As Integer, O As Integer, EE As Integer, SS As Integer
    '=======================================
    If [B2] = False Then MsgBox "تاكد من الشرط في الخلية B2", vbMsgBoxRtlReading, "تنبيه": GoTo 1
    '=======================================
    
                        'اسم ورقة مصدر البيانات
    S = Application.CountA(ورقة1.Range("B6:B1005"))  ' عددالطلبة
    E = [E2]    ' عدد طلاب اللجنة
    T = Application.RoundUp(S / (E * 3), 0)  ' عدد الكشوفات
    TT = Application.RoundUp(S / E, 0)
    W = 7     ' عدد الصفوف الخارجة عن التوزيع في ورقة الكشوفات
    V = 5     ' عدد الصفوف الخارجة عن التوزيع في ورقة البيانات
    H = E + 4 + 3  ' عدد طلاب اللجان زايدا رؤؤس الاعمدة والتذييل
    Set MyRang_1 = Range("راس_اللجان")
    Set MyRang_2 = Range("تذييل_اللجان")
    Set MyRang_Formats = Range("فورمات")
    KH_Clear
    '================================
    Application.ScreenUpdating = False
    ActiveWindow.View = xlPageBreakPreview
    '================================
    For M = 1 To T
        If M <> 1 Then
            MyRang_1.Copy Range("B" & W - 3)
            Set ActiveSheet.HPageBreaks(M - 1).Location = Range("B" & W - 3)
        End If
        Y = 2
        For Z = 1 To 3
            EE = Application.RoundUp((S - (V - 5)) / (TT - SS), 0)
            SS = SS + 1
            MyRang_Formats.Copy
            Cells(W + 1, Y).Resize(E, 5).PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
            MyRang_2.Copy Cells(W + E + 1, Y)
            For N = 1 To EE
                U = N + W: R = N + V
                For C = 1 To 4
                    CC = Choose(C, 11, 2, 8, 10)
                    
                    'اسم ورقة مصدر البيانات
                    Cells(U, Y + C) = ورقة1.Cells(R, CC)
                Next C
                If Cells(U, Y + 1) <> "" Then Cells(U, Y) = N
            Next N
            V = V + EE: Y = Y + 6
        Next Z
        W = W + H
    Next M
    '================================
    ActiveWindow.View = xlNormalView
    With ActiveSheet
        O = .UsedRange.Rows.Count
        .PageSetup.PrintArea = .Range("B4:R" & O).Address
    End With
    '================================
    Application.ScreenUpdating = True
    Range("A4").Activate
    معاينة
    On Error GoTo 0
1 End Sub
Sub KH_Clear()
    Dim Y As Integer
    Application.ScreenUpdating = False
    
'اسم ورقة كشوفات اللجان
    With ورقة2
        Y = .UsedRange.Rows.Count + 8
        .Range("B8:R" & Y).Delete
        .PageSetup.Zoom = 92
        .PageSetup.PrintArea = .Range("B4:R1000").Address
    End With
End Sub
Sub معاينة()
    ActiveWindow.SelectedSheets.PrintPreview
End Sub

جزاكم الله خيرا

تم تعديل يناير 14, 2015 بواسطه قصي

[ibn_egypt]

اخى الفاضل

 

أرفق الملف الأصلي الخاص بالعلامة الفاضل أ.عبد الله باقشير

 

تحياتي  

[قصي]

جزاك الله خيرا وبارك لك الاستاذ الفاضل ابن مصر

وهذا هو الملف الاصلي

توزيع الطلاب1.rar

[inas aly]

ياريت نجد من يعلمنا كيفية تحويل الاكواد الى مثل هذه البدايه السهله التي نضع فبها المتغيرات

[inas aly]

للرفع

[inas aly]

يارب اعنا على فهم الكود وارسل لنا من يذلل هذا الكود

[قصي]

يارب اعنا على فهم الكود وارسل لنا من يذلل هذا الكود

احسن تعبير

يارب اعنا على فهم الكود وارسل لنا من يذلل هذا الكود

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

أعتقد أنه لن يكون لأحد المقدرة على التعديل في الكود وشرحه تمام الشرح إلا العلامة صاحب الكود أستاذنا عبد الله بااقشير - لعل غيابه عنا خير إن شاء الله