مجموعة أكواد ولاأروع

**محمدي عبد السميع** · يونيو 2, 2023

هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا

الأكواد والأعمال لأصحابها وليس لي الفضل الا في تجميعها وتنسيقها

فجزى الله كل من كانت له بصمه في هذا العمل

كلمة سر فتح البرنامج 111

**محمدي عبد السميع** · يونيو 2, 2023

هذا كود لحمايه ملف اكسيل


Sub Protec()
' قبل وضع الكود  ...
'لابد من جعل الخلايا كلها
'unlocked
'حدد خلايا ورقة العمل بالكامل
'ثم كليك يمين ثم اختار آخر تبويب
'ثم أزيل علامة الصح بجانب الخيار
'Lock وكذلك Hidden
'=================
Application.ScreenUpdating = False
    Dim mySheet As Worksheet
    Dim myPassword As String
    
    With Application
        .DisplayFullScreen = False
        .CommandBars("Worksheet Menu Bar").Enabled = True
        .CommandBars("Standard").Visible = True
        .CommandBars("Formatting").Visible = True
        .DisplayFormulaBar = True
        .DisplayStatusBar = False
    End With
    
    myPassword = ""
    
    On Error Resume Next
        For Each mySheet In ActiveWorkbook.Sheets
            With mySheet
                .Unprotect myPassword
                .Cells.Locked = False
                .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
                .Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
                .Protect myPassword
            End With
        Next mySheet
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

هذا كود فك الحمايه


Sub Protec()
' قبل وضع الكود  ...
'لابد من جعل الخلايا كلها
'unlocked
'حدد خلايا ورقة العمل بالكامل
'ثم كليك يمين ثم اختار آخر تبويب
'ثم أزيل علامة الصح بجانب الخيار
'Lock وكذلك Hidden
'=================
Application.ScreenUpdating = False
    Dim mySheet As Worksheet
    Dim myPassword As String
    
    With Application
        .DisplayFullScreen = False
        .CommandBars("Worksheet Menu Bar").Enabled = True
        .CommandBars("Standard").Visible = True
        .CommandBars("Formatting").Visible = True
        .DisplayFormulaBar = True
        .DisplayStatusBar = False
    End With
    
    myPassword = ""
    
    On Error Resume Next
        For Each mySheet In ActiveWorkbook.Sheets
            With mySheet
                .Unprotect myPassword
                .Cells.Locked = False
                .Cells.SpecialCells(xlCellTypeFormulas).Locked = True
                .Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
                .Protect myPassword
            End With
        Next mySheet
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

**محمدي عبد السميع** · يونيو 2, 2023

استدعاء كشوف اللجان

Sub Legan_Test()
     ActiveSheet.Unprotect Password:="1"

    Dim Main          As Worksheet
    Dim sh          As Worksheet
    Dim Arr         As Variant
    Dim arrC        As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim Lr          As Long
    Dim i           As Long
    Dim J           As Long
    Dim k           As Long
    Dim p1          As Long
    Dim p2          As Long
    '=======================
    'اسم صفحة المصدر
    Set Main = Sheets("بيانات الطلبة")

    'اسم صفحة الهدف
    Set sh = Sheets("كشوف المناداة ")

    Lr = Main.Cells(Rows.Count, 5).End(xlUp).Row
    
        Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    'مدى المسح في كشفي اللجان
        sh.Range("C10:F46").ClearContents
        sh.Range("K10:N46").ClearContents
        sh.Rows("10:46").Hidden = False
        
        'مدى صفحة المصدر
        Arr = Main.Range("A7:V" & Lr).Value
        
        'الاعمده المطلوب نقلها من صفحه المصدر
        arrC = Array(2, 5, 15, 16)
        ReDim temp1(1 To UBound(Arr, 1) + 1, 0 To UBound(arrC) + 1)
        ReDim temp2(1 To UBound(Arr, 1) + 1, 0 To UBound(arrC) + 1)
        
        For i = 1 To UBound(Arr)
        
        'رقم عمود رقم اللجان في صفحه المصدر
            If Arr(i, 18) = sh.Range("E3").Value Then
                p1 = p1 + 1
                For J = 0 To UBound(arrC)
                    temp1(p1, J) = Arr(i, arrC(J))
                Next J
            End If
            If Arr(i, 18) = sh.Range("M3").Value Then
                p2 = p2 + 1
                For J = 0 To UBound(arrC)
                    temp2(p2, J) = Arr(i, arrC(J))
                Next J
            End If
        Next i
    
        If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1
        If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2
        
        If p1 > 0 Then k = p1
        If p2 > 0 And p2 > k Then k = p2
        k = k + 10
        
        'لاخفاء الصفوف الفارغه في كشف اللجان
        If k < 46 Then sh.Rows(k & ":46").Hidden = True
             Erase temp1
     Erase temp2

         ActiveSheet.Protect
        Application.Visible = True
            Application.Calculation = xlCalculationAutomatic

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

  '  Application.Calculation = xlManual
   ' Application.EnableEvents = False
    'Application.ScreenUpdating = False

طباعه كشوف اللجان

Sub طباعة_منادااه()
MsgBox "للحصول على طباعة كاملة يجب عدم ملامسة الماوس أو لوحة المفاتيح أثناء الطباعة"
Dim i As Integer
For i = Range("B1") To Range("B2") Step 2
If i <= Range("B2") Then
Range("F1") = i
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
End If
Next i
Range("B10").Select
End Sub

طباعه لجنه واحده من كشوف المناداه

'*****************************
Sub طباعه_لجنه()
Dim LatR As Long
LatR = Range("D:D").Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
With ActiveSheet
    .PageSetup.PrintArea = "A4:O" & LatR
    .PrintOut
End With
End Sub

**محمدي عبد السميع** · يونيو 2, 2023

كود التنقل بين الصفحات

Sub SheetList_CP()
    Application.CommandBars("Workbook Tabs").ShowPopup
        Range("A1").Select
End Sub

طباعه ارقام معينه بالنسبه للتيكيت


Private Sub CommandButton1_Click()
    Dim X As Long, Y As Long, Z As Byte
    ' وضع قيمة التكست بوكس 2 داخل المتغير Y
    Y = TextBox2.Value
    ' وضع قيمة التكست بوكس 3 داخل المتغير Z
    Z = TextBox3.Value
    'حلقة تكرارية بداية من التكست بوكس 1 الى المتغير واي  الذي يحمل قيمة التكست2
    For X = TextBox1.Value To Y
        'هنا يتم وضع ارقام الجلوس تباعا لكل خلية من التسع خلايا
        'اول خلية تساوى المتغير اكس والذي يحمل ارقام الجلوس التى حددناها من قبل
        'والخلية التالية نضع املتغير اكس بالاضافة الى واحد ليحمل رقم الجلوس التالي
        'وهكذا مع الخلايا الاخرى الخاصة بارقام الجلوس
        'اما الشروط المضافة بجانب الخلايا IF[]>y then []=""
        'فهذه تم وضعها فقط للتأكد من ان قيمة الخلايا لا تزيد عن اخر رقم جلوس وهو ما يحمله المتغير واي
        'فاذا تحقق الشرط وكان رقم الجلوس اكبر من اخر رقم يتم مسحه وهذه الشروط لا نستعملها الا في اخر صفحة يتم طباعتها
        [B8] = X: If [B8] > TextBox2.Value Then [B8] = ""
        [B14] = X + 3: If [B14] > Y Then [B14] = ""
        [B20] = X + 6: If [B20] > Y Then [B20] = ""
        [B26] = X + 9: If [B26] > Y Then [B26] = ""
        [B32] = X + 12: If [B32] > Y Then [B32] = ""
        [B38] = X + 15: If [B38] > Y Then [B38] = ""

'============
        [H8] = X + 1: If [H8] > Y Then [H8] = ""
        [H14] = X + 4: If [H14] > Y Then [H14] = ""
        [H20] = X + 7: If [H20] > Y Then [H20] = ""
        [H26] = X + 10: If [H26] > Y Then [H26] = ""
        [H32] = X + 13: If [H32] > Y Then [H32] = ""
        [H38] = X + 17: If [H38] > Y Then [H38] = ""
        
'============
        [N8] = X + 2: If [N8] > Y Then [N8] = ""
        [N14] = X + 5: If [N14] > Y Then [N14] = ""
        [N20] = X + 8: If [N20] > Y Then [N20] = ""
        [N26] = X + 11: If [N26] > Y Then [N26] = ""
        [N32] = X + 14: If [N32] > Y Then [N32] = ""
        [N38] = X + 17: If [N38] > Y Then [N38] = ""

'===========


        'سطر الطباعة وعدد النسخ تساوي z
        'والتى تساوي تكست بوكس تلاته التى نضع بها عدد النسخ المطلوبة
        ActiveWindow.SelectedSheets.PrintOut Copies:=Z    ', Preview:=True
        'هنا نقوم باضافة ثمانية ارقام الى المتغير اكس ليصبح محموعهم 9 ليتخطى تسع ارقام جلوس كل دورة
        'داخل الحلقة التكرارية حتى نهاية الحلقة
        X = X + 18
        'نكست اي يعود مرة اخرى لاول الحلقة التكرارية لتطبيق الاكواد مرة اخرى
    Next
   ' MsgBox "Done.....", 64
    Me.Hide
End Sub
Private Sub UserForm_Activate()
'هنا في حدث تنشيط الفورم
'تكست واحد تساوى اول رقم جلوس
    TextBox1.Text = Sheets("بيانات الطلبة").Range("B7").Value
    'تكست2 تساوي اخر رقم جلوس
    TextBox2.Text = Sheets("بيانات الطلبة").Range("B" & Sheets("بيانات الطلبة").Cells(Rows.Count, 2).End(xlUp).Row).Value
End Sub

**محمدي عبد السميع** · يونيو 2, 2023

اظهاز طلاب الدور التاني


'هذا الكود للمحترم النابغه ياسر خليل
'  الهدف من الكود هو استدعاء بشرط من خارج الكود
'تم هذا الكود في 15/2/2017
'==*==*==*==*==*==*==*==*==*==*
    Sub كشوف_كنترول_ثان()
   ActiveSheet.Unprotect
    Dim Arr     As Variant
    Dim Arry    As Variant
    Dim Lr      As Long
    Dim i       As Long
    Dim J       As Long
    Dim Main As Worksheet
    Dim sh As Worksheet
    Dim NUM1 As Integer
    Dim NUM2 As Integer

    Dim Trgt1 As String
    Dim Trgt2 As String
    
     'رقم عمود البحث
    NUM1 = 133    'عمود الشرط الاول
    NUM2 = 144    'عمود الشرط الثاني

    '=*=*=*=*=*=*=*=*=*=*=*=*
    Set Main = Sheets("رصد الترم الثانى")
    Set sh = Sheets("كشوف الترم الأول")
    
    'خليه البحث
    Trgt1 = sh.Range("D1") & "*"    'الشرط الاول
    Trgt2 = sh.Range("E1").Value    'الشرط الثاني

     On Error Resume Next
     
     'مدى المسح في صفحه الهدف
'===========================================================
    sh.Range("A7:AM1000").ClearContents
'===========================================================
    
    Lr = Main.Cells(Rows.Count, 1).End(xlUp).Row

'===========================================================
    Arr = Main.Range("A7:GB" & Lr).Value
'===========================================================
         'مدى  صفحه الهدف
     Arry = sh.Range("A7:AM1000")
    
    J = 1
    For i = LBound(Arr, 1) To UBound(Arr, 1)
    
        'رقم عمود البحث
     'If arr(i, NUM1) Like Trgt1 Then
     'If arr(i, NUM1) Like Trgt1 & "*" Then
      If Arr(i, NUM1) Like Trgt1 & "*" And Arr(i, NUM2) Like Trgt2 Then

'===========================================================
                 Arry(J, 1) = J
                'العمود الاول بعد المسلسل
                 Arry(J, 2) = Arr(i, 2)
                 Arry(J, 3) = Arr(i, 3)
                 Arry(J, 4) = Arr(i, 140)
                 Arry(J, 5) = Arr(i, 142)
                 Arry(J, 6) = Arr(i, 143)
                 Arry(J, 7) = Arr(i, 14)
                 Arry(J, 8) = Arr(i, 15)
                 Arry(J, 9) = Arr(i, 25)
                 Arry(J, 10) = Arr(i, 26)
                 Arry(J, 11) = Arr(i, 36)
                 Arry(J, 12) = Arr(i, 37)
                 Arry(J, 13) = Arr(i, 47)
                 Arry(J, 14) = Arr(i, 48)
                 Arry(J, 15) = Arr(i, 60)
                 Arry(J, 16) = Arr(i, 61)
                 Arry(J, 17) = Arr(i, 68)
                 Arry(J, 18) = Arr(i, 69)
                 Arry(J, 19) = Arr(i, 75)
                 Arry(J, 20) = Arr(i, 76)
                 Arry(J, 21) = Arr(i, 82)
                 Arry(J, 22) = Arr(i, 83)
                 Arry(J, 23) = Arr(i, 89)
                 Arry(J, 24) = Arr(i, 90)
                 Arry(J, 25) = Arr(i, 96)
                 Arry(J, 26) = Arr(i, 97)
                 Arry(J, 27) = Arr(i, 98)
                 Arry(J, 28) = Arr(i, 99)
                 Arry(J, 29) = Arr(i, 99)
                 Arry(J, 30) = Arr(i, 109)
                 Arry(J, 31) = Arr(i, 110)
                 Arry(J, 32) = Arr(i, 131)
                 Arry(J, 33) = Arr(i, 132)
                 Arry(J, 34) = Arr(i, 133)
                 Arry(J, 35) = Arr(i, 134)
'===========================================================
            
            J = J + 1
        End If
    Next i
    With sh
        
'===========================================================
        'خليه بدايه اللصق
        .Range("B7").Resize(J - 1, UBound(Arry, 2)).Value = Arry
         'مدى المسح في صفحة الهدف
        .Range("A7:AM" & Rows.Count).Borders.Value = 0
'===========================================================
        
        'سطر لاضافة التسطير
        .Range("B7:AM" & .Cells(Rows.Count, 4).End(xlUp).Row).Borders.Value = 1
    End With
         Erase Arr
     Erase Arry

    ActiveSheet.Protect
End Sub

**حسونة حسين** · يونيو 2, 2023

بارك الله فيك استاذ @محمدي عبد السميع

وعودا حميدا الي المنتدي

أبومروان · يونيو 3, 2023

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

**محمدي عبد السميع** · يونيو 3, 2023

يبارك فيكم ربنا

Sub استخراج_حالة_الطالب()
    Dim ARR
    Dim ARRY
    Dim ARRYS
    '___________________________________________
    Dim R As Long
    Dim X As Long
    Dim XX As Byte
    Dim ALL_LESS As String
    Dim Main As Worksheet
    Dim Info As Worksheet

    Set Main = Sheets("رصد الترم الثانى")
    Set Info = Sheets("بيانات المدرسة")

    '___________________________________________
    Const STATUS As Byte = 133    'عمود الحالة ناجح او دور ثان
    Const NOTES As Byte = 134  ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
    Const GENDER As Byte = 141  ' عمود الجنس ذكر او أنثى
    Const TOTAL  As Byte = 98
    Const LESS_ROW As Byte = 6  'صف الدرجة الصغرى
    Const NAM_ROW As Byte = 2    'صف اسماء المواد
    Const NAME_FIRST As Byte = 6  ' (اول صف لاسماء الطلاب -1)
    Const Absent  As Byte = 12    'عدد المواد لحساب الغياب
    Dim NAME_LAST As Long: NAME_LAST = Info.Range("B10").Value + NAME_FIRST   ' عدد الطلاب
   '======
    '_____________________________________________________
    'اعمدة اختبار الترم التاني
    'رقم عمود المجموع يكتب هنا
  ARR = Array(10, 21, 32, 43, 135, 65, 72, 79, 86, 93, 105, 98)
    
    'اعمدة الدرجة النهائية
    'ايضارقم عمود المجموع يكتب هنا
    ARRY = Array(14, 25, 36, 47, 60, 68, 75, 82, 89, 96, 109, 98)
    
    'اعمدة اسماء كل المواد
    'ايضارقم عمود المجموع يكتب هنا
    ARRYS = Array(5, 16, 27, 38, 49, 63, 70, 77, 84, 91, 100, 98)
   '=================
   With Main    'اسم شيت البيانات
        Application.ScreenUpdating = False    'الغاء تحديث الشاشة
        Application.Calculation = xlManual    ' ايقاف الحساب التلقائي
        For R = NAME_FIRST To NAME_LAST    ' حلقة تكرارية تبدأ  بأول اسم طالب الى اخر اسم
            For X = 0 To UBound(ARR)    ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني
                On Error Resume Next
                '____________________________________________________
                'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس
                'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب
                If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then
                    XX = XX + 1
                End If
                '___________________________________________________
                 If ARR(X) = TOTAL Then
                    'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل
                    If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Then
                        ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لنصف الدرجة " & " - ": GoTo 86
                        GoTo 86
                   Else
                        GoTo 86
                   End If
                End If
                '____________________________________________________
  
                'هنا يتم مقارنة المواد بالدرجة الصغرى الخاصة الفصل الدارسي الثاني في اول الكود او اذا كانت غياب يتم اضافة اسم المادة من صف  المواد الى المتغير
                'ALL_LESS
                'او  مقارنة الدرجة النهائية لكل مادة بالدرجة الصغرى لها او اذا كانت غياب اذا تحقق الشرط فيتم اضافة المادة الى المتغير
                'ALL_LESS
                '______________________________________________________
                If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86
                End If
                If .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
                End If
                '______________________________________________________
86          Next X    'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد
             'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب
          If XX = Absent Then ALL_LESS = "غياب  ": XX = 0

            '_____________________________________________________
            'هنا بعد اكتمال الكود يتم عمل شرط للمتغير
            'ALL_LESS
            'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح
            If ALL_LESS = "" Then
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "ناجح "    'اذا كان نوع الطالب ذكر يتم وضع ناجح
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, STATUS) = "ناجحة "    'اذا كانت أنثى يتم وضع ناجحه
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, NOTES) = "ومنقول " & Info.Range("B16")    'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, NOTES) = "ومنقولة " & Info.Range("B16")    'مثل ماسبق
                'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان
            ElseIf ALL_LESS <> "" Then
                If .Cells(R, GENDER) = "ذكر" Then .Cells(R, STATUS) = "له دور ثان في"    'مثل ما سبق بخصوص النوع
                If .Cells(R, GENDER) = "أنثى" Then .Cells(R, STATUS) = "لها دور ثان في"    '
                .Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2)    'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات
                ALL_LESS = Empty    'تفريغ المتغير لاعادة تعبئة اسم طالب اخر
            End If
            '_____________________________________________________
        Next R    'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب
    End With
    Application.ScreenUpdating = True    'اعادة تحديث الشاشة
    Application.Calculation = xlAutomatic    'تشغيل الحساب التلقائي
End Sub

استخراج حالة الطالب ومواد الرسوب نسخه منقحه2.xlsb

**محمدي عبد السميع** · يونيو 3, 2023

البحث بالاســم أو رقم الجلوس

Private Sub ComboBox1_Change()

End Sub

Private Sub CommandButton1_Click()
Dim ws As Worksheet, SC As String
Dim y As Range, x As Range
Set ws = Sheets("SH")
SC = Search.ComboBox1.Text
RG = Search.TextBox2.Value
If SC = "" Then Shihada.Show
If SC = "" Then Exit Sub
For Each y In ws.Range("C12:C" & ws.Range("C" & Rows.Count).End(xlUp).Row)
If y.Value = SC Then
ws.Activate
y.Select
Search.TextBox2.Value = ActiveCell.Offset(0, -1)
Shihada.Label1.Caption = ActiveCell.Offset(0, -1)
Shihada.Label2.Caption = ActiveCell.Offset(0, 0)
Shihada.Label3.Caption = ActiveCell.Offset(0, 2)
Shihada.Label4.Caption = ActiveCell.Offset(0, 8)
Shihada.Label5.Caption = ActiveCell.Offset(0, 18)
Shihada.Label6.Caption = ActiveCell.Offset(0, 28)
Shihada.Label7.Caption = ActiveCell.Offset(0, 39)
Shihada.Label8.Caption = ActiveCell.Offset(0, 51)
Shihada.Label9.Caption = ActiveCell.Offset(0, 59)
Shihada.Label10.Caption = ActiveCell.Offset(0, 63)
Shihada.Label11.Caption = ActiveCell.Offset(0, 68)
Shihada.Label12.Caption = ActiveCell.Offset(0, 73)
Shihada.Label13.Caption = ActiveCell.Offset(0, 78)
Shihada.Label14.Caption = ActiveCell.Offset(0, 83)
Shihada.Label15.Caption = ActiveCell.Offset(0, 89)
Shihada.Label16.Caption = ActiveCell.Offset(0, 99)
Shihada.Label17.Caption = ActiveCell.Offset(0, 109)
Shihada.Label18.Caption = ActiveCell.Offset(0, 9)
Shihada.Label19.Caption = ActiveCell.Offset(0, 19)
Shihada.Label20.Caption = ActiveCell.Offset(0, 29)
Shihada.Label21.Caption = ActiveCell.Offset(0, 40)
Shihada.Label22.Caption = ActiveCell.Offset(0, 52)
Shihada.Label23.Caption = ActiveCell.Offset(0, 60)
Shihada.Label24.Caption = ActiveCell.Offset(0, 64)
Shihada.Label25.Caption = ActiveCell.Offset(0, 69)
Shihada.Label26.Caption = ActiveCell.Offset(0, 74)
Shihada.Label27.Caption = ActiveCell.Offset(0, 79)
Shihada.Label28.Caption = ActiveCell.Offset(0, 84)
Shihada.Label29.Caption = ActiveCell.Offset(0, 90)
Shihada.Label30.Caption = ActiveCell.Offset(0, 100)
Shihada.Label31.Caption = ActiveCell.Offset(0, 110)
Shihada.Label32.Caption = ActiveCell.Offset(0, 117)
Search.ComboBox1.Text = ""
Search.TextBox2.Value = ""
End If
Next
Shihada.Show
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub UserForm_Initialize()
Dim ws As Worksheet
Set ws = Sheets("SH")
ws.Range("C12:C" & ws.Range("C" & Rows.Count).End(xlUp).Row).Name = "Sors"
ComboBox1.RowSource = "Sors"
End Sub

البحث بالاسـم أو زقم الجلوس.xlsb

abomalk · يونيو 3, 2023

بارك الله فيك استاذنا ومتعك الله بالصحه والعافية @محمدي عبد السميع

**محمدي عبد السميع** · يونيو 3, 2023

كود بطريقه أخري لتوزيع كشوف المناداه

Private Sub Worksheet_Change(ByVal Target As Range)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
st = 0
s = 0
lo = 0
lr = 0
k = 0
b = 0
'خليه عدد اللجان
If Target.Address = "$N$11" Then
s = 1
'عمود المسلسل
lr = Range("a" & Rows.Count).End(xlUp).Row

'خليه عدد الطلبه في بيان اللجان
st = Cells(9, 13).Value

'خليه عدد اللجان في بيان اللجان
lo = Cells(9, "n").Value

'خليه باقي الطلبه في بيان اللجان
b = Cells(9, "o").Value

While b >= lo
st = st + 1
b = b - lo
Wend
k = st
If b > 0 Then
st = st + 1
End If

'الصف الاول للاسماء
For i = 8 To lr
If Cells(i, 1).Row - 7 <= st Then
Cells(i, 4) = s
Else
s = s + 1

'رقم عمود رقم اللجنه
Cells(i, 4) = s
If b > 0 Then b = b - 1
If b > 0 Then
st = st + 1
End If
st = st + k
End If
Next
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If Target.HasFormula = True Then
'ActiveCell.Offset(0, 1).Select
'MsgBox ("يوجد هنا معادلات ")
'End If
End Sub

كشف منادة الصف الثالث1.xlsb

**محمدي عبد السميع** · يونيو 3, 2023

تغير الخط في الخليه النشطه

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Const cnNUMCOLS As Long = 256
Const cnHIGHLIGHTCOLOR As Long = 36 'default lt. yellow
Static rOld As Range
Static nColorIndices(1 To cnNUMCOLS) As Long
Dim i As Long
Application.ScreenUpdating = False
If Not rOld Is Nothing Then 'Restore color indices
With rOld.Cells
If .Row = ActiveCell.Row Then Exit Sub 'same row, don't restore
For i = 1 To cnNUMCOLS
If nColorIndices(i) = xlNone Then
.Item(i).Interior.ColorIndex = xlNone
Else
.Item(i).Interior.Color = nColorIndices(i)
End If
Next i
End With
End If
Set rOld = Cells(ActiveCell.Row, 1).Resize(1, cnNUMCOLS)
With rOld
For i = 1 To cnNUMCOLS
nColorIndices(i) = .Item(i).Interior.Color
If .Item(i).Interior.ColorIndex = xlNone Then
nColorIndices(i) = xlNone
Else
nColorIndices(i) = .Item(i).Interior.Color
End If
Next i
.Interior.ColorIndex = cnHIGHLIGHTCOLOR
End With
Application.ScreenUpdating = True
End Sub

الكود الظاهر واحد من الاكواد الموجوده في الملف

تكبير الخط في الخليه النشطه بعدة طرق.xlsb

**محمدي عبد السميع** · يونيو 3, 2023

مجموعه اخرى يكتبها الله في كفه حسناتهم

رقم الدخول 2020

https://www.mediafire.com/file/e4vla3z22dtc11c/_+الرابـع++متميز.xlsb/file

تم ارفاق الملف في المنتدي

_ الرابـع متميز.xlsb

**محمدي عبد السميع** · يونيو 3, 2023

مجموعه اخرى يكتبها الله في كفه حسناتهم

السري 1

في كل شيء

https://www.mediafire.com/file/17v9vr4jjrmb4hw/أكواد+محتلفه.xlsb/file

تم ارفاق الملف في المنتدي

الخامس.xlsb

**محمدي عبد السميع** · يونيو 3, 2023

احضار بيانات الطلاب من موقع الوزاره

احضار بيانات الطلاب من النت.xlsb

**حسونة حسين** · يونيو 3, 2023

بارك الله فيك استاذ @محمدي عبد السميع جعله الله في ميزان حسناتكم يوم القيامة

تم ارفاق الملفات في المنتدي

طلباتك اوامر

**2saad** · يونيو 3, 2023

الأساتذة الأفاضل

بارك الله فيكم وجعله في ميزان حسناتكم

ملحوظة بالنسبة لجلب بيانات التلاميذ من النت

التسجيل علي الموقع اتغير

الدخول بالايميل والرقم السري فقط

ارجو تعديل البرنامج

تسجيل الدخول

مجموعة أكواد ولاأروع

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information