محمدي عبد السميع قام بنشر يونيو 2, 2023 قام بنشر يونيو 2, 2023 هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا الأكواد والأعمال لأصحابها وليس لي الفضل الا في تجميعها وتنسيقها فجزى الله كل من كانت له بصمه في هذا العمل كنترول محمدي9.xlsb كلمة سر فتح البرنامج 111 3
محمدي عبد السميع قام بنشر يونيو 2, 2023 الكاتب قام بنشر يونيو 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 1
محمدي عبد السميع قام بنشر يونيو 2, 2023 الكاتب قام بنشر يونيو 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 1
محمدي عبد السميع قام بنشر يونيو 2, 2023 الكاتب قام بنشر يونيو 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 1
محمدي عبد السميع قام بنشر يونيو 2, 2023 الكاتب قام بنشر يونيو 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
حسونة حسين قام بنشر يونيو 2, 2023 قام بنشر يونيو 2, 2023 بارك الله فيك استاذ @محمدي عبد السميع وعودا حميدا الي المنتدي
أبومروان قام بنشر يونيو 3, 2023 قام بنشر يونيو 3, 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 الكاتب قام بنشر يونيو 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 بارك الله فيك استاذنا ومتعك الله بالصحه والعافية @محمدي عبد السميع
محمدي عبد السميع قام بنشر يونيو 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 الكاتب قام بنشر يونيو 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 الكاتب قام بنشر يونيو 3, 2023 مجموعه اخرى يكتبها الله في كفه حسناتهم رقم الدخول 2020 https://www.mediafire.com/file/e4vla3z22dtc11c/_+الرابـع++متميز.xlsb/file تم ارفاق الملف في المنتدي _ الرابـع متميز.xlsb 1
محمدي عبد السميع قام بنشر يونيو 3, 2023 الكاتب قام بنشر يونيو 3, 2023 مجموعه اخرى يكتبها الله في كفه حسناتهم السري 1 في كل شيء https://www.mediafire.com/file/17v9vr4jjrmb4hw/أكواد+محتلفه.xlsb/file تم ارفاق الملف في المنتدي الخامس.xlsb
محمدي عبد السميع قام بنشر يونيو 3, 2023 الكاتب قام بنشر يونيو 3, 2023 احضار بيانات الطلاب من موقع الوزاره احضار بيانات الطلاب من النت.xlsb 1
حسونة حسين قام بنشر يونيو 3, 2023 قام بنشر يونيو 3, 2023 بارك الله فيك استاذ @محمدي عبد السميع جعله الله في ميزان حسناتكم يوم القيامة تم ارفاق الملفات في المنتدي طلباتك اوامر 1
2saad قام بنشر يونيو 3, 2023 قام بنشر يونيو 3, 2023 الأساتذة الأفاضل بارك الله فيكم وجعله في ميزان حسناتكم ملحوظة بالنسبة لجلب بيانات التلاميذ من النت التسجيل علي الموقع اتغير الدخول بالايميل والرقم السري فقط ارجو تعديل البرنامج
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.