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

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

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

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

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

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

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