محمدي عبد السميع

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

يحفظكم الرحمن

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

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

احسنت يحفظك الرحمن الرحيم

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 '====================================================== '====================================================== ' تنسيق التاريخ Private Const DtF As String = "yyyy/mm/dd" '====================================================== ' عُرض تاكست الادخال Private Const iWgt1 As Single = 240 '====================================================== Private Const Frmtop As Single = 3 Private Const Frmlft As Single = 3 Private Const iHgt As Single = 35 Private Const iTop As Single = iHgt + 2 Private Const mBox As Long = vbMsgBoxRight + vbMsgBoxRtlReading '====================================================== Private Ar() As Integer Private MyRngSeri As Range Private MyRngdate As Range Private ContRow As Long Private iRow As Long Private LastColumn As Integer Private tSr As Boolean Private MyList As String Private tAc As Boolean Private iColor1 As Variant Private iColor2 As Variant Private Sub BoxFind_Click() Dim tm As Integer Me.ListFind.Clear tm = Me.BoxFind.Tag Me.Controls("Labeldt" & tm).ForeColor = vbBlack tm = Me.BoxFind.ListIndex + 1 Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor Me.BoxFind.Tag = tm End Sub Private Sub ButtonClear_Click() kh_ClearRecord End Sub Private Sub ButtonEnd_Click() Me.ScrollBar1.Value = ContRow End Sub Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False) Dim tm As Integer '''''''''''''''''''''''''''''''' For tm = 2 To LastColumn If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then Me.Controls("Textdt" & tm) = "" End If Next End Sub Private Sub kh_AddNewRecord() Dim C As Integer '''''''''''''''''' Me.Frame1.ScrollTop = 0 kh_ClearRecord True '''''''''''''''''' Me.LabelSerial = ContRow + 1 Me.LabelSerial2 = ContRow + 1 & " - " & ContRow + 1 kh_Enabled False '''''''''''''''''' With Me.Controls("Textdt1") If .Enabled Then .SetFocus .Text = "يجب الادخال في هذه الخلية افتراضياً" .SelStart = 0 .SelLength = .TextLength Else .Text = "........" End If End With End Sub Private Sub ButtonGo_Click() With MyRngdate .Worksheet.Activate .Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select End With Unload Me End Sub Private Sub ButtonNew_Click() kh_AddNewRecord End Sub Private Sub ButtonNewCancel_Click() ScrollBar1_Change End Sub Private Sub ButtonNewSave_Click() If kh_TestBlank() Then Exit Sub Dim cRow As Long: cRow = ContRow + 1 Me.ScrollBar1.Max = cRow kh_SaveDate cRow, True Me.ScrollBar1.Value = cRow Call MsgBox(" تم حفظ السجل الجديد بنجاح ", mBox, "الحمدلله") End Sub Private Sub ButtonPrint_Click() If Me.Frame1.ScrollHeight > Me.Frame1.Height Then Print1 Else If MsgBox(" هل تريد طباعة السجل على الفورم ؟ ", vbYesNo + mBox, "طباعة على الفورم ") = vbYes Then Print2 Else Print1 End If End If End Sub Private Sub Print1() Dim ctl As Control Dim i As Integer, t As Boolean Me.Hide '------------------------ With Workbooks.Add(xlWBATWorksheet) .Activate For i = 1 To LastColumn Cells(i, "B").Value = CStr(Me.Controls("Labeldt" & i)) Cells(i, "C").Value = CStr(Me.Controls("Textdt" & i)) Next With Range("B1").Resize(LastColumn, 2) .ColumnWidth = IIf(t, 28, 37) .Borders.LineStyle = 2 .WrapText = True .VerticalAlignment = xlTop End With Range("A1").ColumnWidth = IIf(t, 17, 0) If t Then AddPrintPicture Range("A1").Resize(LastColumn, 3).PrintPreview .Close False End With '------------------------ Me.Show End Sub Private Sub Print2() Print_Visible False '''''''''''''''''''''''''' If MsgBox(" هل تريد طباعة الفورم حسب هذه المعاينة ؟ ", vbYesNo + mBox, "معاينة قبل الطباعة") = vbYes Then On Error Resume Next Me.PrintForm On Error GoTo 0 End If '''''''''''''''''''''''''' Print_Visible True kh_Enabled True End Sub Private Sub Print_Visible(v As Boolean) Dim ctl As Control '''''''''''''''''''''''''' If v Then Me.BackColor = iColor1 With Me.Frame1 .BackColor = iColor2 .SpecialEffect = 3 End With Else Me.BackColor = vbWhite With Me.Frame1 .BackColor = vbWhite .SpecialEffect = 0 End With End If End Sub Private Sub ButtonSaveDate_Click() If kh_TestBlank() Then Exit Sub kh_SaveDate iRow ScrollBar1_Change Call MsgBox(" تم حفظ التغييرات بنجاح ", mBox, "الحمدلله") End Sub Private Function kh_TestBlank() As Boolean If Len(Trim(Me.Controls("Textdt1"))) = 0 Then kh_TestBlank = True Me.Controls("Textdt1").SetFocus Call MsgBox("العمود : " & Me.Controls("Labeldt1") & vbCr & vbCr & "يجب الادخال في هذه الخلية افتراضياً", mBox + vbCritical, "استخدام خاطىء") End If End Function Private Sub kh_AutoFill() Dim CelFill As Range, CFil As Range Dim R As Integer '''''''''''''''''''''''''' If tSr Then Set CelFill = Union(MyRngSeri, MyRngdate) Else Set CelFill = MyRngdate End If '''''''''''''''''''''''''' For R = 1 To CelFill.Areas.Count Set CFil = CelFill.Areas(R).Rows(ContRow + 1) With CFil .AutoFill .Resize(2), xlFillDefault End With Next Set CelFill = Nothing Set CFil = Nothing End Sub Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False) Dim MyVelue, Msg Dim C As Integer, cc As Integer '''''''''''''''''''''''''' 'On Error GoTo 1 '''''''''''''''''''''''''' Application.Calculation = xlCalculationManual '''''''''''''''''''''''''' If nR > 1 And tFil Then kh_AutoFill If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR ''''''''''''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) If Me.Controls("Textdt" & cc).Enabled = True Then With MyRngdate MyVelue = Me.Controls("Textdt" & cc).Text If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Else If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then Msg = MsgBox("الخلية في العمود : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _ & "منسقة كتاريخ والادخال الجديد رقم" & vbCr & vbCr _ & "هل تريد مسح تنسيقات الارقام السابقة ؟؟", mBox + vbYesNo, "تأكيد مسح تنسيقات التاريخ السابقة ؟؟ ") ''''''''''''''''''''''''' If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = "" End If End If .Cells(nR + 1, C).Value = MyVelue End With End If Next '''''''''''''''''''''''''' 1: Application.Calculation = xlCalculationAutomatic '''''''''''''''''''''''''' End Sub Private Sub ButtonExit_Click() Unload Me End Sub Private Sub ButtonDelete_Click() If MsgBox(" هل تريد حذف السجل رقم : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "تاكيد الحذف ") = vbNo Then Exit Sub If Me.ListFind.ListCount Then Me.ListFind.Clear MyRngdate.Rows(iRow + 1).EntireRow.Delete If Not tSr Then GoTo 1 If iRow = ContRow Then GoTo 1 With MyRngSeri .Cells(iRow + 1, 1).Value = iRow Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries End With 1: Me.ScrollBar1.Max = ContRow - 1 ScrollBar1_Change Call MsgBox(" تم حذف السجل بنجاح ", mBox, "الحمدلله") End Sub Private Sub ButtonTop_Click() If ContRow Then Me.ScrollBar1.Value = 1 End Sub Private Sub CheckFind_Click() Me.ListFind.Clear Me.LblFindCount = 0 End Sub Private Sub CheckFindDate_Click() If Me.CheckFindDate.Value = True Then kh_SetDate Me.TextFind '''''''''''''''''''''''''''' End If End Sub Private Sub CommandButton1_Click() ActiveWorkbook.save Call MsgBox(" تم حفظ الكل بنجاح ", mBox, "الحمدلله") End Sub Private Sub CommandButton2_Click() ChaingeLanguage "Arabic" TextFind.SetFocus End Sub Private Sub CommandButton3_Click() ChaingeLanguage "English" TextFind.SetFocus End Sub Private Sub CommandButton4_Click() Me.TextFind.Value = "" End Sub Private Sub CommandButton6_Click() a = Application.Height - 10: b = Application.Width With Me .Width = .Width * 1.1 .Height = .Height * 1.1 .zoom = .zoom * 1.1 .Top = (a - .Height) / 2 .Left = (b - .Width) / 2 End With End Sub Private Sub CommandButton7_Click() a = Application.Height - 10: b = Application.Width With Me .Width = .Width / 1.1 .Height = .Height / 1.1 .zoom = .zoom / 1.1 .Top = (a - .Height) / 2 .Left = (b - .Width) / 2 End With End Sub Private Sub LabelH2_Click() Call MsgBox(" سيتم تحويل اي قيمة تضعها في مربع النص للبحث " _ & vbCr & vbCr & "الى تاريخ بالتنسيق الافتراضي للفورم ,,,,,,," _ & vbCr & String$(40, "=") _ & vbCr & vbCr & "مع امكانية ادخال رقم صحيح بين 1 الى 31 ليفهم على انه " _ & vbCr & vbCr & "تاريخ اليوم للشهر الحالي والسنة الحالية " _ , mBox + vbQuestion + vbApplicationModal, "تعليمات") ''''''''''''''''''''''''''' End Sub Private Sub ListFind_Click() Dim RR As Long RR = Me.ListFind.Column(1) Me.ScrollBar1.Value = RR End Sub Private Sub ScrollBar1_Change() Dim MyVelue Dim C As Integer, cc As Integer Me.Frame1.ScrollTop = 0 With Me.ScrollBar1 If ContRow = 0 Then .Min = 1 iRow = .Value: ContRow = .Max End With ''''''''''''''''' For cc = 1 To LastColumn C = Ar(cc) With MyRngdate If IsDate(.Cells(iRow + 1, C)) Then MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF) Else: MyVelue = .Cells(iRow + 1, C).Value2 End If End With On Error Resume Next Me.Controls("Textdt" & cc).Text = "" Me.Controls("Textdt" & cc).Text = MyVelue On Error GoTo 0 Next '------------------------------ Me.LabelSerial.Caption = iRow Me.LabelSerial2.Caption = iRow & " - " & ContRow kh_Enabled True End Sub Private Sub TextBox1_Change() End Sub Private Sub TextFind_Change() With Me.ListFind If .ListCount Then .Clear End With Me.LblFindCount = 0 Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False) End Sub Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) If Me.CheckFindDate.Value = False Then Exit Sub kh_SetDate Me.TextFind End Sub ' هذا الكود يرغمك بادخال تاريخ Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control) Dim dtest, dt dtest = dCntrl If Not IsDate(dtest) Then If IsNumeric(dtest) Then On Error Resume Next dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF) If Err Then dt = Format(Date, DtF) On Error GoTo 0 Else dt = Format(Date, DtF) End If Else: dt = Format(CDate(dtest), DtF) End If dCntrl = dt End Sub Private Sub TextSerial_Change() Dim v v = Me.TextSerial.Text If Len(v) = 0 Then Exit Sub If Not IsNumeric(v) Then GoTo 1 If v = 0 Or v > ContRow Then GoTo 1 Exit Sub '======================= 1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1) End Sub Private Sub TextSerial_AfterUpdate() If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = "" End Sub Private Sub kh_Enabled(ByVal Ebl As Boolean) Me.ButtonNewSave.Visible = Not Ebl Me.ButtonNewCancel.Visible = Not Ebl Me.ButtonNew.Visible = Ebl Me.ButtonSaveDate.Visible = Ebl '''''''''''''''''''''''''''''''''''''''''''' Me.ButtonPrint.Enabled = Ebl Me.ButtonSaveDate.Enabled = Ebl Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False) '''''''''''''''''''''''''''''''' Me.ButtonEnd.Enabled = CBool(iRow <> ContRow) Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1) Me.ButtonNewCancel.Enabled = IIf(iRow, True, False) Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl) End Sub Private Sub ButtonSerach_Click() Dim tb1 As Boolean, ib As Boolean Dim R As Long, RR As Long Dim C As Integer Dim MyFind, MySrch, MyVelue '''''''''''''''''''''' Me.ListFind.Clear If Len(Trim(Me.TextFind)) = 0 Then Exit Sub ''''''''''''''''''''' C = Me.BoxFind.ListIndex + 1 tb1 = CBool(Me.CheckFindDate.Value = True) If tb1 Then If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind MyFind = CDbl(CDate(Me.TextFind)) Else MyFind = Me.TextFind.Value End If ''''''''''''''''''''''' With MyRngdate.Cells(2, Ar(C)) For R = 1 To ContRow If Len(Trim(.Cells(R, 1))) Then If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare)) If ib Then MyVelue = .Cells(R, 1).Value If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF) Me.ListFind.AddItem MyVelue Me.ListFind.List(RR, 1) = R RR = RR + 1 End If End If Next End With Me.LblFindCount = Me.ListFind.ListCount If RR = 0 Then MsgBox " لا توجد نتائج لبحثك هذا ", mBox, "تنبيه" ''''''''''''''''''''''''' End Sub Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "") tSr = TypeName(Evaluate(aSr)) = "Range" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With ThisWorkbook If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr) Set MyRngdate = .Worksheets(MySht).Range(MyAddrs) End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With MyRngdate ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row LastColumn = .Cells.Count End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim Col As Range Dim ii As Integer ReDim Ar(1 To LastColumn) For Each Col In MyRngdate.Cells ii = ii + 1 Ar(ii) = Col.Column - MyRngdate.Column + 1 Next ''''''''''''''''''''''''''' End Sub Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean If Not Rng.Comment Is Nothing Then MyList = Trim(Replace(Rng.Comment.Text, Chr(10), "")) MyList = Replace(MyList, " ", "") If TypeName(Evaluate(MyList)) = "Range" Then kh_TestType = True End If End If End Function Private Sub UserForm_Activate() Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double Dim MyBox As Control, MyLabl As Control Dim t As Integer Dim tTp As Boolean Dim MyType As String ''''''''''''''''''''' If tAc Then Exit Sub ''''''''''''''''''''' Me.Caption = MyRngdate.Worksheet.Name MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2) With Frame1 If MyScrollHeight > .Height Then .ScrollBars = 2 .ScrollHeight = MyScrollHeight End If End With MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2)) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' For t = 1 To LastColumn tTp = kh_TestType(MyRngdate.Cells(1, Ar(t))) MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1") Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True) With MyBox .Move Frmlft, MyTop, iWgt1, iHgt .TextAlign = 3 If tTp Then .BackColor = 16763955 .ControlTipText = "إختر من القائمة..تحياتى عبدالبارى البنا" On Error Resume Next .List = Range(MyList).Value If Err Then .AddItem Range(MyList).Cells(1, 1).Value On Error GoTo 0 End If If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then .BackStyle = 0 .TextAlign = 2 .SpecialEffect = 3 .Enabled = False End If End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True) With MyLabl .Move iWgt1 + Frmlft, MyTop, MyWith, iHgt .SpecialEffect = 3 .TextAlign = 2 .Caption = MyRngdate.Cells(1, Ar(t)) End With ''''''''''''''''''''''''''''''''''' Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2 MyTop = MyTop + iTop Next ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.BoxFind .Style = 2 .Tag = 1 .ListIndex = 0 End With ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Me.ScrollBar1 .Max = ContRow If ContRow Then .Min = 1 '.Value = ContRow Else kh_AddNewRecord End If End With tAc = True ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Me.TextBox1.Value = ورقة13.Range("f18").Value CheckFind.Value = True End Sub Private Sub UserForm_Initialize() Dim LaCouleur As String Dim Te LaCouleur = xlThemeColorLight1 Te = ("&&..الله اكبر..&& اهلا بكم فى برنامج شئون العاملين بالتربية والتعليم ........................إعداد وتصميم .. عبدالبارى البنا &&..ولله الحمد..&&") Me.WebBrowser1.Navigate _ "about:<html><body scroll='no'><font color= " & LaCouleur & " size='4' face='NEW'>" & _ "<marquee direction=right>" & Te & "</marquee></font></body></html>" 'Dim Zo% 'Dim ZH#, ZW#, AL#, AT#, AH#, AW# 'Dim FH!, FW! ''''''''''''''''''''''' 'AH = Application.Height: AW = Application.Width 'AL = Application.Left: AT = Application.Top 'FH = Height: FW = Width 'ZH = AH - FH: ZW = AW - FW: Zo = zoom 'If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW) ''''''''''''''''''''''' 'Move AL, AT, AW, AH 'If Zo <> 100 Then zoom = Zo '=========================================== iColor1 = Me.BackColor iColor2 = Me.Frame1.BackColor End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ' Me.TextBox1.Value = ورقة13.Range("f18").Value End Sub Private Sub UserForm_Terminate() Set MyRngdate = Nothing Erase Ar End Sub Private Sub WebBrowser1_StatusTextChange(ByVal Text As String) End Sub كود اخر ولا في الاحلام

Option Explicit '====================================================== ' اول صف للتقرير Private Const iRow As Integer = 8 '------------------------------------------------------ ' اسم ورقة التقارير Private Const Sh_Report As String = "التقرير" '------------------------------------------------------ ' اسم ورقة البيانات Private Const Sh_MyDate As String = "data" '------------------------------------------------------ ' تعيين نطاق الخلايا في ورقة البيانات ' ويشمل رؤوس الاعمدة Private Const MyRng_MyDate As String = "A2:z1000" '====================================================== Private MyRng As Range Private Num As Integer Private Const Mycount As Integer = 10 Private Sub CommandButton1_Click() Dim R As Integer Application.ScreenUpdating = False For R = 1 To Num If Me.Controls("CheckBox" & R).Value = True Then Kh_Start R End If Next Kh_PageSetup Application.GoTo Range("A1"), True Application.ScreenUpdating = True Unload Me End Sub Private Sub Kh_Start(iColumn As Integer) Dim RCount As Long, C As Integer C = Cells(iRow, Columns.Count).End(xlToLeft).Column + 1 With MyRng RCount = .Cells(.Rows.Count, 1).End(xlUp).Row .Cells(1, iColumn).Resize(RCount, 1).Copy ' لصق عرض الاعمدة Cells(iRow, C).PasteSpecial xlPasteColumnWidths ' لصق الفورمات Cells(iRow, C).PasteSpecial xlPasteFormats ' لصق القيم Cells(iRow, C).PasteSpecial xlPasteValues Application.CutCopyMode = False End With End Sub Private Sub UserForm_Initialize() Dim MyTop As Integer, i As Integer Dim MyCBox As Control '======================== kh_MyRngSet '======================== MyTop = 0 For i = 1 To Num Set MyCBox = Frame1.Controls.Add("Forms.CheckBox.1") With MyCBox .Move 12, MyTop, , , True .Alignment = 0 .Font.Bold = True .Caption = MyRng.Cells(1, i).Value .Value = True .TextAlign = fmTextAlignRight End With MyTop = MyTop + 24 Next '======================== With Me If Num <= Mycount Then .Height = 60 + (24 * Num) .Frame1.Height = (24 * Num) Else .Height = 60 + (24 * Mycount) .Frame1.Height = (24 * Mycount) .Frame1.ScrollBars = 2 .Frame1.ScrollHeight = (Num) * 24 End If End With '======================== End Sub Private Sub kh_MyRngSet() With Sheets(Sh_Report) .Select .Range(Cells(iRow, 2), Cells(.Rows.Count, .Columns.Count)).Clear .PageSetup.PrintArea = "" End With With Sheets(Sh_MyDate) Set MyRng = .Range(MyRng_MyDate) End With Num = MyRng.Columns.Count End Sub Private Sub Kh_PageSetup() Dim Lastrow As Long Dim LastColumn As Integer With Sheets(Sh_Report) Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row LastColumn = .Cells(iRow, Columns.Count).End(xlToLeft).Column With .PageSetup .PrintArea = Range("B2", Cells(Lastrow, LastColumn)).Address .zoom = False .FitToPagesWide = 1 .FitToPagesTall = False End With End With End Sub Private Sub UserForm_Terminate() Set MyRng = Nothing End Sub البرنامج كنز يحتوي على مجموعه من الاكواد ولا أروع هذا الكود للعلامه عبد الله باقشير

كلمة المرور لبرنامج شوون العاملين مكتوبه في المشاركه الاولي وعموما هي 1111

هل نتعشم من النابغه الاستاذ حسونه شرح اسطر الكود

اضافه للنابغه الأستاذ حسونه حسن يبارك له ربنا اربط هذا الكود بزر الاستدعاء Sub Test(Arr1 As Variant) ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Temp As Variant ', Arr1 As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub SS_Show() Subjects.Show End Sub استدعاء بيانات بطريقه الفورمه 99(5).xlsb

برنامج لعمل كشوف الملاحظه لرجال التربيه والتعليم Sub dub() Application.ScreenUpdating = False On Error Resume Next If Sheets("data") Is Nothing Then Sheets("source").Visible = True Sheets("source").Copy Before:=Sheets(3) ActiveSheet.Name = "data" If ActiveSheet.Range("c3") > 3 Then t = ActiveSheet.Range("c3") - 3 For i = 1 To t ActiveSheet.Columns("i:i").Select Selection.Copy Selection.Insert Shift:=xlToRight Next 'Application.CutCopyMode = False For n = 1 To ActiveSheet.Range("c3") i = 11 For x = 8 To 8 + ActiveSheet.Range("c3") - 1 ActiveSheet.Cells(i, x) = "المادة" & n n = n + 1 Next Next End If 'ActiveWorkbook.Names("المواد").Delete 'tt = ActiveSheet.Range("المواد") + 2 'End If If ActiveSheet.Range("c2") > 10 Then t = Application.WorksheetFunction.Round(((ActiveSheet.Range("c2"))) / 2, 0) - 5 For i = 1 To t Application.ScreenUpdating = False m = ActiveSheet.Range("last1").Row - 2 ActiveSheet.Rows(m).Select Selection.Copy Selection.Insert Shift:=xlDown Next If ActiveSheet.Range("E4") = 1 Then t = Application.WorksheetFunction.Round((ActiveSheet.Range("c2")) / 2, 0) - 5 - 1 GoTo 77 Else t = Application.WorksheetFunction.Round((ActiveSheet.Range("c2")) / 2, 0) - 5 GoTo 77 End If 77: For i = 1 To t m = ActiveSheet.Range("last2").Row - 2 ActiveSheet.Rows(m).Select Selection.Copy Selection.Insert Shift:=xlDown Next End If x = 2 xx = 7 i = 12 ' بداية صف المجموعة الاولي y = i + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 ' 22نهاية صف المجموعة الاولي ii = 6 yy = ii + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 '16 نهاية صف النسخ iii = y + 3 '25 بداية صف المجموعة الثانية If ActiveSheet.Range("d4") = 1 Then yyy = iii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) - 1 ' 34نهاية صف المجموعة الثانية Else yyy = iii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) ' 35نهاية صف المجموعة الثانية End If iiii = yy + 1 If ActiveSheet.Range("d4") = 1 Then yyyy = iiii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) - 1 ' 22نهاية صف المجموعة النسخ Else yyyy = iiii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) End If ActiveSheet.Range(Cells(i, xx - 1).Address, Cells(y, xx).Address).Value = Sheets("شيت البيانات").Range(Cells(ii, x - 1).Address, Cells(yy, x).Address).Value ActiveSheet.Range(Cells(iii, xx - 1).Address, Cells(yyy, xx).Address).Value = Sheets("شيت البيانات").Range(Cells(iiii, x - 1).Address, Cells(yyyy, x).Address).Value Application.CutCopyMode = True color ActiveSheet.Range("g12").Select ActiveWorkbook.Names("المواد").Delete tt = ActiveSheet.Range("c3") + 7 mn = Cells(11, 8).Address mo = Cells(11, tt).Address ActiveWorkbook.Names.Add Name:="المواد", RefersTo:=ActiveSheet.Range(mn, mo) Application.ScreenUpdating = False ActiveSheet.Range("C2:G5").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False ActiveSheet.Range("C2").Select Application.ScreenUpdating = True Application.CutCopyMode = False ' ="'data'!"$C$11:$V$11 Else If MsgBox("هل تريد الاستمرار سيتم الغاء شيت Data", vbOKCancel, "officena- Go ?") <> vbOK Then Exit Sub Application.DisplayAlerts = False Sheets("Data").Delete Application.DisplayAlerts = True End If Sheets("source").Visible = False Application.ScreenUpdating = True End Sub Sub h1() a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = 12 'بداية صف المجموعة الاولي nb = Range("lastco").Column + 1 vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address)) For i = 12 To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Dim Low As Double Dim High As Double Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "ح" And Cells(i, xx + 1) = "ح" And Cells(i, a + 1) < [e3] And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then Cells(i, xx) = "ح" 'End If End If End If End If Next Next If Cells(b + 1, nb) < [e5] Then vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address)) For i = 12 To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "ح" And Cells(i, xx + 1) = "ح" And Cells(i, a + 1) < [e3] And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then Cells(i, xx) = "ح" 'End If End If End If End If Next Next End If If Cells(b + 1, nb) < [e5] Then 0: vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address)) For i = 12 To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i, xx + 1) <> "ح" And Cells(i, a + 1) < [e3] + 1 And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then Cells(i, xx) = "ح" End If End If End If Next Next End If If Cells(b + 1, nb) < [e5] Then vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address)) For i = 12 To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i, a + 1) < [e3] + 1 And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then Cells(i, xx) = "ح" End If End If End If Next Next End If If Cells(b + 1, nb) < [e5] Then GoTo 0 End Sub Sub h2() 'If Range("c5") > 0 Then a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي e = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = e + 3 'بداية صف المجموعة الثانية If Range("E4") > 0 Then b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية Else b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية End If nb = Range("lastco").Column + 1 vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address)) For i = c To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Dim Low As Double Dim High As Double Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "" And Cells(i, xx + 1) = "" And Cells(i, a + 1) < [f4] And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then Cells(i, xx) = "ح" 'End If End If End If End If Next Next If Cells(b + 1, nb) < [f5] Then vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address)) For i = c To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "" And Cells(i, xx + 1) = "" And Cells(i, a + 1) < [f4] And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then Cells(i, xx) = "ح" 'End If End If End If End If Next Next End If If Cells(b + 1, nb) < [f5] Then 0: vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address)) For i = c To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i, a + 1) < [f4] + 1 And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then Cells(i, xx) = "ح" End If End If End If Next Next End If If Cells(b + 1, nb) < [f5] Then vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address)) For i = c To b 'i = vv For x = 8 To a If Cells(i, a + 1) = vv Then 'mn = Cells(n, x).Row i = Cells(i, a + 1).Row Low = 8 High = a * 2 xx = Int((High - Low) * Rnd() + Low) 'If i < 62 Then If xx < a + 1 Then If Cells(i, xx) = "" And Cells(i, a + 1) < [f4] + 1 And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then Cells(i, xx) = "ح" End If End If End If Next Next End If If Cells(b + 1, nb) < [f5] Then GoTo 0 End Sub Sub h1tem() If Range("E2") <= 0 Then Exit Sub If Range("g1") > 1 Then a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = 12 'بداية صف المجموعة الاولي For Each cell In Range(Cells(12, 8).Address, Cells(b, a).Address) If cell.Value = "" Or cell.Value = 0 Then cell.Value = "ح" End If Next End If End Sub Sub num1() Dim Low As Double Dim High As Double [A1500] = "" [a2000] = "" ActiveSheet.Range("A1000") = "" a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 0: m = Range("h12").Address n = Cells(b, a).Address 'If ActiveSheet.CheckBox1.Value = 0 Then 'Range(m, n) = "" 'End If Application.ScreenUpdating = False 'h1 For x = 8 To a For i = 12 To b For n = 1 To [c4] Low = n High = [c4] n = Round(((High - Low) * Rnd() + Low), 0) 'If r <= a Then 'If n >= 1 Then If Cells(i, x) = "" Then If Cells(i, x - 1) <> n Then Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")" Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")" v = [A1500] v1 = [a2000] If v = 0 And v1 = 0 Then 'On Error GoTo 88 'If Cells(i, x) = "" Then Cells(i, x) = n 'End If End If 'End If End If End If Next Next Next 'tem1 For i = 12 To b For x = 8 To a For n = 1 To [c4] Low = n High = [c4] n = Round(((High - Low) * Rnd() + Low), 0) If Cells(i, x) = "" Then If Cells(i, x - 1) <> n Then Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")" Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")" v = [A1500] v1 = [a2000] If v < 2 And v1 = 0 Then Cells(i, x) = n End If End If End If Next Next Next 'tem1 For i = 12 To b For x = 8 To a For n = 1 To [c4] If Cells(i, x) = "" Then Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")" Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")" v = [A1500] v1 = [a2000] If v <= 2 And v1 = 0 Then Cells(i, x) = n End If End If Next Next Next 'tem1 test If ActiveSheet.CheckBox1.Value = False Then If Range("bad") = 1 Then m = Range("h12").Address n = Cells(b, a).Address Range(m, n) = "" h1 GoTo 0 End If End If Application.ScreenUpdating = True 'End '88: 'GoTo 1 End Sub Sub num2() a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = d + 3 'بداية صف المجموعة الثانية If ActiveSheet.Range("E4") > 0 Then b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية GoTo 10 Else b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية GoTo 10 End If 10: For x = 8 To a For i = 12 To d For y = c To b 'If Range("E4") = 0 Then If ActiveSheet.Cells(i, x) > 0 And ActiveSheet.Cells(i, x) <> "ح" Then 'GoTo 0 'Else 'If Range("E4") <> 0 Then 'If Cells(i, x) > 0 And Cells(i, x) <> "ح" And Cells(i, x) < Range("c4") Then 'GoTo 0 'End If 'End If 0: bb = ActiveSheet.Cells(i, 7).Interior.ColorIndex bc = ActiveSheet.Cells(i, 7).Font.ColorIndex If vvvv = 1 Then GoTo 3 v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(y, 8).Address & ":" & ActiveSheet.Cells(y, a).Address), ActiveSheet.Cells(i, x).Value) v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), ActiveSheet.Cells(i, x).Value) If v = 0 And v1 = 0 Then Dim Low As Double Dim High As Double Low = c High = b + 10 r = Int((High - Low) * Rnd() + Low) If r >= c And r <= b Then If ActiveSheet.Cells(r, x) = "" Then 3: vvc = 0 For Each cell In ActiveSheet.Range(Cells(r, 8).Address, ActiveSheet.Cells(r, a).Address) If cell.Interior.ColorIndex = bb And cell.Font.ColorIndex = bc Then vvc = vvc + 1 End If Next 'If Range("E4") = 0 Then If vvc <= ActiveSheet.Range("c5") Then 'GoTo 1 'Else 'If Range("E4") <> 0 Then 'If vvc < [c5] Then 'GoTo 1 'End If 1: ActiveSheet.Cells(r, x) = ActiveSheet.Cells(i, x) ActiveSheet.Cells(r, x).Interior.ColorIndex = bb ActiveSheet.Cells(r, x).Font.ColorIndex = bc End If End If End If End If End If 'End If 'End If 'End If Next Next Next End Sub Sub test() a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = d + 3 'بداية صف المجموعة الثانية If Range("E4") > 0 Then b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية Else b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية End If Range("bad") = "" i = d + 2 For x = 8 To a If Cells(i, x) = "توزيع خاطئ" Then Range("bad") = 1 End If Next 'i = b + 2 'For x = 8 To a 'If Cells(i, x) = "توزيع خاطئ" Then 'Range("bad") = 1 'End If 'Next End Sub Sub color() a = 8 + [c3] - 1 'عدد الاعمدة d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الاولي c = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) + 2 'بداية صف المجموعة الثانية If Range("E4") > 0 Then b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية Else b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية End If m = Cells(12, 8).Address n = Cells(d, a).Address o = Cells(c, 8).Address p = Cells(b, a).Address For i = 12 To d If Cells(i, 6) > 0 Then If Cells(i, 6) > 56 Then Cells(i, 7).Interior.ColorIndex = Cells(i, 6) - 56 Cells(i, 7).Font.ColorIndex = 3 Else Cells(i, 7).Interior.ColorIndex = Cells(i, 6) End If End If Next Range(Cells(c, 6).Address, Cells(b, 7).Address).Interior.ColorIndex = xlNone Range(o, p).Interior.ColorIndex = Range("g" & d).Interior.ColorIndex + 4 Range(m, n).Interior.ColorIndex = 35 Range(Cells(d + 1, 8).Address, Cells(d + 1, a).Address).Interior.ColorIndex = 37 Range(Cells(b + 1, 8).Address, Cells(b + 1, a).Address).Interior.ColorIndex = 38 End Sub Sub tem1() a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 i = b + 2 For x = 8 To a If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then For bb = 12 To b If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then For n = 1 To ActiveSheet.Range("c4") + 10 0: v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(12, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n) v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n) If Range("E4") < 0 Then If v = 0 And v1 < ActiveSheet.Range("c5") Then If n <= ActiveSheet.Range("c4") Then ActiveSheet.Cells(bb, x) = n End If End If End If Next End If Next End If Next i = b + 2 For x = 8 To a If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then For bb = 12 To b If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then For n = 1 To ActiveSheet.Range("c4") 1: v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(12, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n) v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n) If v = 0 And v1 <= [c5] + 1 Then If n <= ActiveSheet.Range("c4") Then If Cells(bb, Range("lastco").Row) <= Range("d3") Then ActiveSheet.Cells(bb, x) = n End If End If End If Next End If Next End If Next End Sub Sub tem2() a = 8 + [c3] - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = d + 3 'بداية صف المجموعة الثانية If ActiveSheet.Range("E4") > 0 Then b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية GoTo 10 Else b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية GoTo 10 End If 10: i = b + 2 For x = 8 To a If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then For bb = c To b If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then For n = 1 To [c4] + 10 If n <= ActiveSheet.Range("c4") Then 0: v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n) v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n) If v = 0 Then ActiveSheet.Cells(bb, x) = n For hh = 12 To d If ActiveSheet.Cells(hh, x) = n Then cc = ActiveSheet.Cells(hh, 7).Interior.ColorIndex bc = ActiveSheet.Cells(hh, 7).Font.ColorIndex GoTo fl End If Next fl: ActiveSheet.Cells(bb, x).Interior.ColorIndex = cc ActiveSheet.Cells(bb, x).Font.ColorIndex = bc End If End If Next End If Next End If Next i = b + 2 For x = 8 To a If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then For bb = c To b If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then For n = 1 To ActiveSheet.Range("c4") + 10 If n <= ActiveSheet.Range("c4") Then 1: v = Application.WorksheetFunction.CountIf(Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n) v1 = Application.WorksheetFunction.CountIf(Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n) If v = 0 And v1 <= 2 Then ActiveSheet.Cells(bb, x) = n For hh = 12 To d If ActiveSheet.Cells(hh, x) = n Then bc = ActiveSheet.Cells(hh, 7).Font.ColorIndex cc = ActiveSheet.Cells(hh, 7).Interior.ColorIndex GoTo cl End If Next cl: ActiveSheet.Cells(bb, x).Interior.ColorIndex = cc ActiveSheet.Cells(bb, x).Font.ColorIndex = bc End If End If Next End If Next End If Next End Sub Sub allone1() m = Cells(Range("lastco").Row + 4, Range("lastco").Column + 8).Address n = Cells(Range("lastco").Row + 200, Range("lastco").Column + 11).Address Range(m, n) = "" a = 3 + ActiveSheet.Range("c2") - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = d + 3 'بداية صف المجموعة الثانية If ActiveSheet.Range("E4") > 0 Then b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 - 1) 'نهاية صف المجموعة الثانية GoTo 10 Else b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1) 'نهاية صف المجموعة الثانية GoTo 10 End If 10: cf = Cells(Range("lastco").Row + 4, Range("lastco").Column + 9).Column For x = 8 To 8 + ActiveSheet.Range("c3") - 1 For i = c To b If Cells(i, x).Interior.ColorIndex = Cells(Range("lastco").Row + 3, Range("lastco").Column + 7) Then With Columns(cf).Rows(1000).End(xlUp) .Offset(1, 0) = Cells(i, 2) .Offset(1, 1) = Cells(i, x) .Offset(1, 2) = Cells(11, x) End With End If Next Next For x = 8 To 8 + ActiveSheet.Range("c3") - 1 For i = 12 To d If Cells(i, 2).Interior.ColorIndex = Cells(Range("lastco").Row + 3, Range("lastco").Column + 7) Then Cells(Range("lastco").Row + 4, Range("lastco").Column + 8) = Cells(i, 2) If Cells(i, x) = "ح" Then With Columns(cf).Rows(1000).End(xlUp) .Offset(1, 0) = "-" .Offset(1, 1) = "ح" .Offset(1, 2) = Cells(11, x) End With End If End If Next Next End Sub Sub allone2() m = Cells(Range("lastco").Row + 4, Range("lastco").Column + 13).Address n = Cells(Range("lastco").Row + 200, Range("lastco").Column + 16).Address Range(m, n) = "" a = 8 + ActiveSheet.Range("c2") - 1 'عدد الاعمدة 'نهاية صف المجموعة الاولي d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 c = d + 3 'بداية صف المجموعة الثانية If ActiveSheet.Range("d4") > 0 Then b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 - 1) 'نهاية صف المجموعة الثانية GoTo 10 Else b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1) 'نهاية صف المجموعة الثانية GoTo 10 End If 10: cf = Cells(Range("lastco").Row + 4, Range("lastco").Column + 14).Column For x = 8 To 8 + ActiveSheet.Range("c3") - 1 For i = c To b If Cells(i, 1) = Cells(Range("lastco").Row + 3, Range("lastco").Column + 13) Then Cells(Range("lastco").Row + 4, Range("lastco").Column + 13) = Cells(i, 2) If Cells(i, x) <> "ح" Then For n = 12 To d If Cells(n, 7).Interior.ColorIndex = Cells(i, x).Interior.ColorIndex Then With Columns(cf).Rows(1000).End(xlUp) .Offset(1, 0) = Cells(n, 2) .Offset(1, 1) = Cells(n, x) .Offset(1, 2) = Cells(11, x) End With End If Next End If End If Next Next For x = 8 To 8 + ActiveSheet.Range("c3") - 1 For i = c To b If Cells(i, 1) = Cells(Range("lastco").Row + 3, Range("lastco").Column + 13) Then Cells(Range("lastco").Row + 4, Range("lastco").Column + 13) = Cells(i, 2) If Cells(i, x) = "ح" Then With Columns(cf).Rows(1000).End(xlUp) .Offset(1, 0) = "-" .Offset(1, 1) = "ح" .Offset(1, 2) = Cells(11, x) End With End If End If Next Next End Sub Sub xxxcc() 'If Target.Column = 19 And Target.Row = 9 Then Range("t10:y210") = "" 'If Target <> "" Then i = 11 For x = 8 To Sheets("data").Range("c2") - 1 If Sheets("data").Cells(i, x) = Sheets("شيت طبع كشف الملاحظة").Range("s9") Then z = Sheets("data").Cells(i, x).Column GoTo 0 End If Next 0: For y = 12 To d If IsNumeric(Sheets("data").Cells(y, z)) And Sheets("data").Cells(y, z) > 0 And Sheets("data").Cells(y, 2) <> "" Then ' Sheets("شيت طبع كشف الملاحظة").Cells(yy, 1) Then With Columns(20).Rows(210).End(xlUp) .Offset(1, 0) = Sheets("data").Cells(y, z) .Offset(1, 1) = Sheets("data").Cells(y, 2) End With End If Next For yyy = 12 To d If Sheets("data").Cells(yyy, z) = "ح" Then With Columns(22).Rows(210).End(xlUp) .Offset(1, 0) = Sheets("data").Cells(yyy, z) .Offset(1, 1) = Sheets("data").Cells(yyy, 2) End With End If Next End Sub Function aahsum(aa As Variant) f = 0 For n = 1 To aa.Value f = f + n Next aahsum = f End Function برنامج ساقبة اللجان.xlsb

Sub Test_A() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 5, 6) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_B() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 8, 9) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_C() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 11, 12) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '--------------------------------------------------------------------- If Arr(i, 4) = Ws.Range("D3").Value Then '----------------------------------------------------------------------- p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_D() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 14, 15) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '----------------------------------------- If Arr(i, 4) = Ws.Range("D3").Value Then '----------------------------------------- p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_E() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 17, 18) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_F() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 20, 21) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_G() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 23, 24) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_H() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 26, 27) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub SS_Show() Subjects.Show End Sub استدعاء بيانات بطريقه الفورمه.xlsb استدعاء بيانات بطريقه الفورمه للعلامه باقشير

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

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

مجموعه اخرى يكتبها الله في كفه حسناتهم السري 1 في كل شيء https://www.mediafire.com/file/17v9vr4jjrmb4hw/أكواد+محتلفه.xlsb/file تم ارفاق الملف في المنتدي الخامس.xlsb

مجموعه اخرى يكتبها الله في كفه حسناتهم رقم الدخول 2020 https://www.mediafire.com/file/e4vla3z22dtc11c/_+الرابـع++متميز.xlsb/file تم ارفاق الملف في المنتدي _ الرابـع متميز.xlsb

تغير الخط في الخليه النشطه 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

كود بطريقه أخري لتوزيع كشوف المناداه 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

البحث بالاســم أو رقم الجلوس 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

يبارك فيكم ربنا 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

اظهاز طلاب الدور التاني 'هذا الكود للمحترم النابغه ياسر خليل ' الهدف من الكود هو استدعاء بشرط من خارج الكود 'تم هذا الكود في 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

كود التنقل بين الصفحات 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

استدعاء كشوف اللجان 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

هذا كود لحمايه ملف اكسيل 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

هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا الأكواد والأعمال لأصحابها وليس لي الفضل الا في تجميعها وتنسيقها فجزى الله كل من كانت له بصمه في هذا العمل كنترول محمدي9.xlsb كلمة سر فتح البرنامج 111