علي فاهم

للرفع

مثال عدد طلاب الصف الدراسي 200 طالب ضغطنا الزر فنسخ صفوف بعدد 200 .. بعد اسبوع جاء الي المدرسه طالب محول .. مطلوب اضافته للمدرسه فيكون عدد طلاب المدرسه 201 الطالب المحول + الطلاب المنقولون

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

اوهذا الكود الرائع ولكن مشكله المسح التي تلافاها استاذ ياسر خليل في كوده السابق نريده بنسخ بعد الصفوف الموجوده فعلا ولايمسح 'هذا الكود للمحترم ياسر العربي ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب 'وقبل النسخ يتم مسح البيانات القديمه 'تاريخ الانشاء 30/7/2017 '=*=*=*=*=*=*=*=*=*=*=*=*=*=* Private Sub CommandButton1_Click() Dim sh As Worksheet, lr As Long, str As String If TextBox1.Text = Sheets("بيانات الطلبة").Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل If Sheets("بيانات الطلبة").Cells(2, 3) < 2 Then Exit Sub End If '=*=*=*=*=*=* 'On Error Resume Next For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "كشف ناجح")) lr = sh.Range("B" & sh.Range("b10000").End(xlUp).Row).Row sh.Activate ' str المتغير دا يتم تخزين اسم العمود الاخير فيه للعمل عليه 'يتم الذهاب الى اخر عمود بالاعتماد على الصف السادس ويتم استخلاص اسم العمود من اسم النطاق str = Split(sh.Range("XFD7").End(xlToLeft).Address, "$")(1) 'حذف البيانات الموجودة في النطاق المحدد sh.Range("A8:" & str & lr + 7).Clear ' نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين sh.Range("a7:" & str & 7).AutoFill Destination:=Range("a7:" & str & [ 'بيانات الطلبة'!C2] + 6) Next Sheets("بيانات الطلبة").Select Range("A4").Select Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Unload Me Else MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب" TextBox1.Text = "" TextBox1.SetFocus End If End Sub Private Sub Label1_Click() End Sub Private Sub UserForm_Click() End Sub اي الكودين .. بعد اذنكم وشكرا مقدما لحضراتكم

جزاكم الله خيرا هذا الكود الرائع نريده ينسخ بعد اخر صف به بيانات .. لايمسح بيانات بعد اذنكم 'هذا الكود للمحترم ياسر العربي ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب 'وقبل النسخ يتم مسح البيانات القديمه 'تاريخ الانشاء 30/7/2017 'تم التعديل على الكود بواسطه المحترم ياسر خليل لوجود متطلبات جديده '=*=*=*=*=*=*=*=*=*=*=*=*=*=* Private Sub CommandButton1_Click() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Dim lc As Long Dim c As Long Set ws = Sheets("بيانات الطلبة") c = ws.Range("C2").Value If TextBox1.Text = ws.Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64 Application.ScreenUpdating = False Application.Calculation = xlManual 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل If ws.Range("C2") < 2 Then Exit Sub End If For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "رصد الترم الثانى", "كشف ناجح")) lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh)) lc = LastOccupiedColNum(sh) 'حذف البيانات الموجودة في النطاق المحدد sh.Range("A8").Resize(Rows.Count - 7, lc).Clear 'نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc) Next sh Application.Goto ws.Range("A1") Application.Calculation = xlAutomatic Application.ScreenUpdating = True Unload Me Else MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation TextBox1.Text = "" TextBox1.SetFocus End If End Sub Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long Dim lng As Long If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then With Sheet lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row End With Else lng = 1 End If LastOccupiedRowNum = lng End Function Public Function LastOccupiedColNum(Sheet As Worksheet) As Long Dim lng As Long If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then With Sheet lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column End With Else lng = 1 End If LastOccupiedColNum = lng End Function '================================== Private Sub UserForm_Click() End Sub لايوجد له ثغره روعه

جزاكم الله خيرا هذا الكود الرائع نريده ينسخ بعد اخر صف به بيانات .. لايمسح بيانات بعد اذنكم 'هذا الكود للمحترم ياسر العربي ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب 'وقبل النسخ يتم مسح البيانات القديمه 'تاريخ الانشاء 30/7/2017 'تم التعديل على الكود بواسطه المحترم ياسر خليل لوجود متطلبات جديده '=*=*=*=*=*=*=*=*=*=*=*=*=*=* Private Sub CommandButton1_Click() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Dim lc As Long Dim c As Long Set ws = Sheets("بيانات الطلبة") c = ws.Range("C2").Value If TextBox1.Text = ws.Range("F1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64 Application.ScreenUpdating = False Application.Calculation = xlManual 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل If ws.Range("C2") < 2 Then Exit Sub End If For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف الدور الثاني", "رصد الترم الثانى", "كشف ناجح")) lr = IIf(LastOccupiedRowNum(sh) = 7, 7, LastOccupiedRowNum(sh)) lc = LastOccupiedColNum(sh) 'حذف البيانات الموجودة في النطاق المحدد sh.Range("A8").Resize(Rows.Count - 7, lc).Clear 'نسخ الصف السابع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين sh.Range("A7").Resize(1, lc).AutoFill Destination:=sh.Range("A7").Resize(c, lc) Next sh Application.Goto ws.Range("A1") Application.Calculation = xlAutomatic Application.ScreenUpdating = True Unload Me Else MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation TextBox1.Text = "" TextBox1.SetFocus End If End Sub Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long Dim lng As Long If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then With Sheet lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row End With Else lng = 1 End If LastOccupiedRowNum = lng End Function Public Function LastOccupiedColNum(Sheet As Worksheet) As Long Dim lng As Long If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then With Sheet lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column End With Else lng = 1 End If LastOccupiedColNum = lng End Function '================================== Private Sub UserForm_Click() End Sub لايوجد له ثغره روعه

البقاء لله اخي الكريم ناصر اللهم ارحمه واغفر له واجعل قبره روضه من رياض الجنه

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

جزاك الله كل خير استاذ حماده

ربنا يحفظك ايها العالم الكبير عبد الله باقشير

هذا هو العنوان الذي اريد اضافه الملف فيه جزاك الله خيرا

انا احترمك يا استاذ مجدي بالنسبه لشرحك للبرنامج رائع فهو مفيد .. فقد توقف منشء الموضوع عن المشاركه وهو استاذ محمود الشريف استاذ مجدي معذره اردت ان احمل برنامج خبور المدرسي الاصدار الاول فلم اوفق ووجدت رابطا اخر ارجو اضافته في موضوع برنامج خبور المدرسي الاصدار الاول لعله ينفع احد الاخوة وهذا هو الرابط http://up.top4top.net/downloadf-4340o7re1-rar.html

متعك الله بالصحه يا استاذ مجدي

كيف اعدل الاسم يا استاذ مجدي ؟

استاذ مجدي اعدك بان اغير الاسم عشان انا باحترمك كتير ارجو الملف بالباور

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

ربنا يحفظك .. انا في انتظارك لهذه الصوره بالباور بوينت

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

كرما منك ارجو ارفاق ملف الصور بالبور بوينت

شاء ربنا ان اكون اول من يرد على العملاق الكبير عمر الحسيني يجزيك الله كل خير تمام التمام .. كمل جميلك واشرحه

LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12 Range("AY13:AZ" & LastRow_1).ClearContents Dim MyBoolean As Boolean Sub اضافة_حذف() On Error Resume Next Dim XX As Shape Set XX = ActiveSheet.Shapes("الدائرة") With XX.TextFrame.Characters If .Text = "اضافة الدوائر" Then Circles1 .Text = "حذف الدوائر" Else Kh_DeletShape .Text = "اضافة الدوائر" End If End With On Error GoTo 0 End Sub Sub Circles1() On Error Resume Next Dim MyRng_All As Range, c As Range Dim V As Shape, S As String Dim K As Integer, x As Integer, d As Long, N As Integer, y As Integer Dim عمود_رقم_الجلوس As Integer, صف_مواد_دور_ثاني As Integer, صف_الدرجات As Integer Dim عمود_حالة_الطالب As Integer, عمود_المواد As Integer '================================================ عمود_رقم_الجلوس = 2 صف_الدرجات = 12 صف_مواد_دور_ثاني = 8 عمود_حالة_الطالب = 51 عمود_المواد = 52 y = Sheets("بيانات المدرسة").Range("B10").Value + 12 Set MyRng_All = Range("p13", Cells(y, 51)) ' نطاق الخلايا الذي تريد اضافة الدوائر فيها '================================================ x = ActiveWindow.Zoom Application.ScreenUpdating = False LastRow_1 = Cells(Rows.Count, "C").End(xlUp).Row + 12 Range("AY13:AZ" & LastRow_1).ClearContents ActiveWindow.Zoom = 100 For Each c In MyRng_All K = c.Column If Cells(c.Row, عمود_رقم_الجلوس) = 0 Then GoTo 3 If Cells(صف_مواد_دور_ثاني, c.Column) <> "م" Then If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _ And (c.Value < Cells(صف_الدرجات, c.Column) Or c.Value = "غ" Or c.Value = "غـ") Then If MyBoolean Then GoTo 1 Kh_AddShape c, V d = d + 1 End If 1 Else If IsNumeric(Cells(صف_الدرجات, c.Column)) And Not IsEmpty(Cells(صف_الدرجات, c.Column)) _ And (c.Value < Cells(صف_الدرجات, c.Column) Or Cells(c.Row, c.Column - 1) < Cells(صف_الدرجات, c.Column - 1) Or Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ") Then If Cells(c.Row, c.Column - 1) = "غ" Or Cells(c.Row, c.Column - 1) = "غـ" Then N = N + 1 '================================================ ' ترحيل مواد دورثاني ان وجدت If Cells(c.Row, عمود_المواد) = "" Then S = "" Else S = " - " Cells(c.Row, عمود_المواد) = Cells(c.Row, عمود_المواد) & S & Cells(صف_مواد_دور_ثاني - 1, c.Column) '================================================ If MyBoolean Then GoTo 2 Kh_AddShape c, V d = d + 1 End If End If '================================================ ' ترحيل حالة الطالب 2 If K = MyRng_All.Columns.Count + MyRng_All.Column - 1 Then If N = 4 Then Cells(c.Row, عمود_حالة_الطالب) = "غائب": Cells(c.Row, عمود_المواد) = "جميع المواد" _ Else If Cells(c.Row, عمود_المواد) = "" Then Cells(c.Row, عمود_حالة_الطالب) = "ناجح ومنقول للصف الثالث" Else Cells(c.Row, عمود_حالة_الطالب) = "له دور ثاني في" N = 0 End If '================================================ 3 Next ActiveWindow.Zoom = x Application.ScreenUpdating = True If MyBoolean Then GoTo 4 MsgBox "تم إضافة " & d & " دائرة بنجاح" & Chr(10) & Chr(10) & "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله" On Error GoTo 0 4 End Sub Sub Kh_AddShape(MyCell As Range, Kh_shp As Shape) Set Kh_shp = ActiveSheet.Shapes.AddShape(msoShapeOval, MyCell.Left, MyCell.Top, MyCell.Width, MyCell.Height) With Kh_shp .Fill.Visible = msoFalse .Line.ForeColor.SchemeColor = 10 .Line.Weight = 2.25 End With End Sub Sub Kh_DeletShape() Dim myshape As Shape, d As Long For Each myshape In ActiveSheet.Shapes If myshape.Type = 1 Then myshape.Delete: d = d + 1 Next myshape MsgBox "تم حذف " & d & " دائرة بنجاح", vbMsgBoxRight, "الحمدلله" End Sub Sub تحديث() MyBoolean = True Circles1 MyBoolean = False MsgBox "تم تحديث حالةالطالب" & Chr(10) & Chr(10) & "تم تحديث مواد دور ثاني", vbMsgBoxRight, "الحمدلله" End Sub تمت هذه الاضافه بارك الله في الاستاذ ابو عبد الباري

الله .. الله على الحل السحري ربنا يكرمك استاذ عمر الحسيني

هل من جديد يا اساتذه

ربنا يحفظك استاذ أنس دروبي

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 Sub Frame1_Click() End Sub Private Sub Im1_Click() End Sub Private Sub UserForm_Activate() Application.Visible = False Nour_A End Sub Sub Nour_A() On Error Resume Next secondes = 0.05 For a = 1 To 100 timer_avant = Timer Do While Timer < timer_avant + secondes DoEvents Me.Im1.Width = a + a + a / 2.2 Me.Nour1.Caption = a Loop Next 'Application.Visible = True 'Sheet1.Activate Me.Hide UserForm2.Show End Sub Private Sub UserForm_Initialize() dawenleod.Left = 0 dawenleod.Top = 0 Dim lngWindow As Long, lFrmHdl As Long lFrmHdl = FindWindow(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) Me.Height = 210 End Sub ده الكود واثناء التشغيل يظهر اسم عبد الباري والكود لايوجد به الاسم دلوني حفظكم الله