قوائم الفصول .. ولا أروع للعلامه عبد الله باقشير

[ناصر سعيد]

تكوين قوائم فصول المدرسة

هذا الملف من ابداع العلامة عبد الله باقشير .. وهو خاص بتكوين قوائم للفصول المدرسيه .. ولاأروع منه

جزاه الله عنا كل خير وبارك له

=*=*=*=*=*=*=

طريقه العمل مع الملف

* املأ الجدول الموجود بالخلايا V6 :W20  بصفحة بيانات اساسيه بما يتناسب مع بيانات مدرستك

* املأ بيانات طلاب مدرستك بفصولها كامله ( جميع الصفوف  الدراسيه )  في الجدول الموجود بالخلايا C6: O..

* انتقل الى صفحة تكوين فصل واكتب في الخليه E5 رقم الصف الذي تريد قائمة فصل من فصوله

وفي الخليه F5 اكتب رقم الفصل

* اضغط الزر KH_START

اذا اردت جوده المظهر في القائمه ..  فحمل الخطوط الموجوده  ادناه ...  في جهازك اولا

=*=*=*=*=*=

ادعو الله ان يكون هذا العمل متقبلا من الله

تكوــــــــــــــــــــــــين فصول.rar

====================

خط.rar

==========

رابط لخطوط غايه في الجمال والروعه

https://up.top4top.net/downloadf-3206k2ma1-rar.html

تم تعديل يونيو 15, 2017 بواسطه ناصر سعيد
بسبب تنسيق الخط

[ناصر سعيد]

=============================

Sub KH_START()
'هذا الكود خاص بالعالم العلامه عبد الله باقشير
'الهدف من الكود هو توزيع الطلاب على قوائم
'تم هذا العمل في 2/8/2006
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Dim MyRange As Range
Dim R As Integer, C As Integer, M As Integer, Y As Integer, t As Integer
Set MyRange = Range("School")
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

'=================================
' مسح البيانات
KH_ClearContents
'=================================
' فرز School
KH_Sort
'=================================
If IsEmpty(Range("E2")) Or IsNumeric(Range("E2")) = False Then t = 40 Else t = Range("E2").Value
C = 10
With MyRange
    For R = 1 To .Rows.Count
        If .Cells(R, 2) <> "" Then
            If .Cells(R, 13).Text = Range("E5").Text And .Cells(R, 14).Text = Range("F5").Text Then
                If Range("D5").Text = "" Then GoTo 1
                If .Cells(R, 3).Text = Range("D5").Text Then
1               If M >= t Then Y = 6: M = 0
                    M = M + 1
                    If Y = 6 Then Cells(C + M, Y + 2) = M + t Else Cells(C + M, Y + 2) = M
                    Cells(C + M, Y + 3) = .Cells(R, 2)
                    Cells(C + M, Y + 4) = .Cells(R, 8)
                    Cells(C + M, Y + 5) = .Cells(R, 4)
                    Cells(C + M, Y + 6) = .Cells(R, 10)
                End If
            End If
        End If
    Next R
End With
'=================================
'اخفاء الصفوف المتبقية من التعيين
If t = 40 Then GoTo 2
With Range("B11:L50")
    .Offset(t, 0).Resize(40 - t).EntireRow.Hidden = True
End With
'=================================
    Application.Calculation = xlCalculationAutomatic

2 Application.ScreenUpdating = True
End Sub
Sub KH_ClearContents()
With Range("B11:L50")
    .ClearContents
   .EntireRow.Hidden = False
End With
End Sub
Sub KH_Sort()
With Range("School")
    .Sort .Columns("B:B"), xlAscending
    .Sort .Columns("C:C"), xlDescending
End With
End Sub

ربنا يجزيك خيرا ايها العالم الجليل عبد الله باقشير

=======

'هذا الكود خاص بالعالم العلامه عبد الله باقشير
'=*==*==*==*==*==*==*==*
Option Explicit
Dim OldColor
Dim جدول_التجميع()
Dim Col As Integer

Private Sub Check_Text_Click()
نص_البحث_Change
End Sub

Private Sub UserForm_Activate()
If ActiveSheet.CodeName = "ورقة7" Then
    With قائمة_البحث
        .Visible = True
        .AddItem " الاسم   / "
        .AddItem "  رقم الجلوس / "
        .Text = .List(0)
    End With
Else
    نص_البحث.Width = 145.75
End If
End Sub
Private Sub زر_الخروج_Click()
If فورم_البحث.Height = 50 Then ActiveCell.Resize(1, 1 + Col).Interior.ColorIndex = OldColor
End
End Sub
Private Sub زر_الفتح_Click()
ActiveCell.Resize(1, 1 + Col).Interior.ColorIndex = OldColor
فورم_البحث.Height = 300
زر_الفتح.Visible = False

End Sub
Private Sub قائمة_البحث_Change()
If قائمة_البحث.ListIndex = 0 Then Col = 5 Else Col = 2
نص_البحث.Text = ""
End Sub
Private Sub لست_البحث_Click()
Dim cc As String
cc = جدول_التجميع(لست_البحث.ListIndex)
Range(cc).Resize(1, 1 + Col).Activate
OldColor = Range(cc).Interior.ColorIndex
Range(cc).Resize(1, 1 + Col).Interior.ColorIndex = 6
فورم_البحث.Height = 50
زر_الفتح.Visible = True
End Sub
Private Sub زر_البحث_Click()
On Error GoTo 0
1 End Sub
Private Sub نص_البحث_Change()
On Error Resume Next
Dim MyWorksheet As Worksheet
Dim R As Integer, C As Integer, v As Integer
Dim M As String, MyTextFind As String
Dim MyCell As Range, A As Range
Set MyWorksheet = ActiveSheet
لست_البحث.Clear
If نص_البحث.Text = "" Then GoTo 1
'====================
If ActiveSheet.CodeName = "ورقة7" And Check_Text.Value = True Then _
M = قائمة_البحث.Text & نص_البحث.Text _
Else M = نص_البحث.Text
'========================================
If Check_Text.Value = True Then MyTextFind = M & "*" _
Else: MyTextFind = "*" & M & "*"
'========================================

With MyWorksheet
    R = .UsedRange.Rows.Count
    C = .UsedRange.Columns.Count
    Set MyCell = Range(.Cells(1, 1), .Cells(R, C))
    For Each A In MyCell
        If ActiveSheet.CodeName = "ورقة7" And Check_Text.Value = False Then
            If A.Value Like MyTextFind And Left(A.Value, Len(قائمة_البحث.Text)) = قائمة_البحث.Text Then
                لست_البحث.AddItem A.Value
                ReDim Preserve جدول_التجميع(v)
                جدول_التجميع(v) = A.Address
                v = v + 1
             End If
        Else
            If A.Value Like MyTextFind Then
                لست_البحث.AddItem A.Value
                ReDim Preserve جدول_التجميع(v)
                جدول_التجميع(v) = A.Address
                v = v + 1
            End If
        End If
    Next
End With
On Error GoTo 0
1 End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode <> 1 And فورم_البحث.Height = 50 Then
  ActiveCell.Resize(1, 1 + Col).Interior.ColorIndex = OldColor ' Cancel = 1
End If
End Sub

ربنا يجزيك خيرا ايها العالم الجليل عبد الله باقشير

[زياد عبد الجليل]

بارك الله فيك استاذ على هذا العمل القيم

لدي استفسار فقط حول كيف يمكنني رؤية التاكس بوكس من محرر الاكواد حيث انني لما ادخل للفيجوال بيسك لا تظهر لي التاكس بوكس كيف يمكنني مشاهدتها و التعديل في في خصوصيتها و شكرا

[ناصر سعيد]

كود طباعه مطاط رائع

جزى الله من وضعه بكل خير وحفظه الله

Sub طباعة_فصل()
Dim LatR As Long
LatR = Range("C:C").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
With ActiveSheet
    .PageSetup.PrintArea = "A3:M" & LatR
    .PrintOut
End With
End Sub

لطباعه صفحة قائمه الفصل التي تختلف في عدد صفوفها من فصل لاخر

[ناصر سعيد]

 

Sub Sort_Male()
    Dim lr As Long
    lr = Range("E" & Rows.Count).End(xlUp).Row
    Range("E7:Q" & lr).Sort Key1:=Range("F7:F" & lr), _
    Order1:=2, Header:=xlNo
End Sub

كود فرز الطلاب

ضع هذا الكود في موديول واعمل له ..  زر بصفحه بيانات المصدر

لاتقلق هذا فرز ليأتي بالذكور اولا

واذا اردت ان تجعله يأتي بالبنات اولا

فما عليك الا ان تغير الرقم 2 الموجود في الكود وتجعله الرقم  1

[ناصر سعيد]

 

    Sub SortData()
    Dim LR As Long
    LR = Range("B" & Rows.Count).End(xlUp).Row
    'مدى الفرز .. ثم معيار الفرز الاول
    'ثم معيار الفرز التاني
    Range("B9:K" & LR).Sort Key1:=Range("E9:E" & LR), Order1:=2, Key2:=Range("B9:B" & LR), Order2:=1, Header:=xlNo
    
End Sub

لفرز البنون والبنات ثم فرز البنون هجائيا وفرز البنات هجائيا

[ناصر سعيد]

 

=================

 

[ناصر سعيد]

 

[ناصر سعيد]

Sub SortData()

    Dim lr As Long

    lr = Range("E" & Rows.Count).End(xlUp).Row

    For Each Cell In ActiveSheet.Range("E7:E" & lr)

        Cell.Value = Application.WorksheetFunction.Trim(Cell.Value)

    Next

    Range("B7:S" & lr).Sort Key1:=Range("F7:F" & lr), Order1:=2, Key2:=Range("E7:E" & lr), Order2:=1, Header:=xlNo

End Sub

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

ولكن به اضافه مفيده

وهي ازاله المسافات من بين الاسماء

مما تعطي فرزا دقيقا

للمحترم الغالي ياسر العربي