asdhamdey

هل يمكن جعل المدى مطاط بعدد الطلاب فتزيد السرعه لانه بطيء جدا جزاكم الله خيرا

' 'هذا الكود للمحترم ياسر العربي Sub RoundedRectangle3_Click() Dim last As Long Dim y As Long '' اول صف سيوضع فيه التذييل y = 40 Do ' ' لمنع اهتزاز الشاشه Application.ScreenUpdating = False last = Sheets("ناجح").Range("a10000").End(xlUp).Row If y - 36 >= last Then GoTo 0 ' ' اسم شيت المصدر الذي سيتم حشر الديباجخ فيه Sheets("كعب الشيت").Rows("2:7").Copy ' ' اسم شيت الديباجه التى نريد وضعها في الشيت المصدر Sheets("ناجح").Rows(y).Insert Shift:=xlDown ' 'لايقاف خاصيه القص والنسخ Application.CutCopyMode = False ' ' y = y + 36 Loop ' ' لاعاده تحديث الشاشه 0 Application.ScreenUpdating = True MsgBox "تم بحمد لله" End Sub ' ' ' ' ' ' ' ' ' ' ' ' اقتباس ( الاستاذ الكريم ياسر العربي وضغت شرح لبعض الجمل لكودك الرائع ليكون مرجعا سهلا للاخوه ارجو ان تكمل الشرح للجمل التي لم استطع شرحها )

اليس هذا الموضوع تكرار

في صفحة ارقام الجلوس المدرسه اعدادها كتيره نرجو اضافه الفصل حتى يسهل توزيع الارقام

الشاب اشرف المحترم مامعنى الارقام في هذه المعادله ="الصف الاول الاعدادى لجنة رقم ( "&((ROW()+($E$2+1))/($E$2+7)*3)-2&" )" ال

جزاك الله كل خير راااااااائع في كشوف المناداه نحتاج عدد المسلمين وعدد المسيحيين ياريت تجعل رأس اللجنه 5 صفوف استعير كلمات اخي قصي اهم نقطه هي ماهي المتغيرات التي نفعلها في الكود عندما يتغير صف بداية الطلاب الموجود في صفحة البيانات ويجزيك الله بكل خير

استاذ عبد الباري انا ارشحك لكي تكون مشرفا بالمنتدى العظيم شرف للمنتدى مثلك .. الملف ممتاز ولكنه لايعمل بعد تغيير عدد الطلاب اكثر من 4 محاولات جرب وشوف

لو ان عدد الطلاب 500 وبعد كده اردنا ان ندخل عدد الطلاب 100 فإن الصفوف ال500 تظل مملوءه بالمعادلات نريد ان يلتزم الكود بعدد الطلاب فقط وتمسح الصفوف الغير ذلك

يبارك فيك ربنا يا استاذ عبد الباري اولا يجب شكرك ثانيا عند تغيير عدد الطلاب الموجود في الخليه بي 4 المفروض ان يوجد هذا العدد من الصفوف فقط مملوءه بالمعادلات والتنسيقات الصف ال1000 ليه هو المطلوب من اجل ان يتم الاستفاده القصوى من الكود لجميع الكنترولات فبعضهم يبدأ من الصف 7 والاخر من الصف 11 والرقم متغير اذن افضل حل هو الصف ال1000

المطلوب من كل هذه الاكواد المفيدة بارك الله في صانعها هو مطلوب كود منهم يتم تطويعه لينسخ الصف 1000 الموجود بالملف ويتم لصقة ابتداء من الصف ال11 بالعدد الموجود في الخليه B4 بنفس معادلاته وتنسيقاته جزاكم الله خيرا

وهذا رابط الكود http://www.officena.net/ib/?showtopic=33712

Option Explicit '****************************************************** ' تعيين نطاق الخلايا التي يتم نسخها Private Const MyRng_Copy As String = "B4:I4" '------------------------------------------------------ ' MyRng_Copy تعيين رقم العمود من النطاق ' الذي سياخذ منه آخر صف للصق Private Const MyColumn As Integer = 4 '****************************************************** Sub Kh_Insert_Rows() On Error Resume Next Dim MyRow As Integer, LastRow As Integer MyRow = 1 MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & MyRow, Title:="ادراج عدد محدد من صفوف ", Default:=MyRow, Type:=1) If MyRow = False Then Exit Sub With Range(MyRng_Copy) LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count If LastRow = 0 Then LastRow = 1 .Copy With .Offset(LastRow, 0).Resize(MyRow, .Columns.Count) .PasteSpecial xlPasteAll .SpecialCells(xlCellTypeConstants).ClearContents End With .Columns(1).Offset(LastRow, 0).Select End With Application.CutCopyMode = False MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله" On Error GoTo 0 End Sub ------------------------------------------------------------------- Sub Kh_Clear_Rows() On Error Resume Next Dim LastRow As Integer With Range(MyRng_Copy) LastRow = Range(.Cells(1, MyColumn), .Cells(1, MyColumn).End(xlDown)).Rows.Count .SpecialCells(xlCellTypeConstants).ClearContents If LastRow = 0 Then GoTo 1 .Cells(2, 1).Resize(LastRow, .Columns.Count).Clear End With 1: MsgBox "تم المسح بنجاح", 524288 + 1048576, "الحمدلله" On Error GoTo 0 End Sub هذا كود اخر لو تكرمتم اريد الحل في ملفي

بارك الله فيكم وجزاكم الله خيرا

جزاكم الله خيرا

وهذا هو الكود Sub KH_Copy() On Error Resume Next Dim Last As Long Dim Count As Integer Count = 1 Count = Sheets("KHBOOR").Range("F9").Value With ActiveSheet Last = .Range("A" & .Rows.Count).End(xlUp).Row .Rows(Last).Copy .Rows(Last + 1).Resize(Count) .Rows(Last + 1).Resize(Count).SpecialCells(xlConstants).ClearContents End With On Error GoTo 0 End Sub

رابط به كود لنسخ صف ارجو تعديله ليتلاءم معنا http://www.officena.net/ib/index.php?showtopic=31449

للرفع

المسامح كريم

للرفع رفع الله قدركم

Sub kh_Copy_Formula() On Error GoTo kh_Err kh_Application False '============================================= kh_cFormula Range("الاول!$b$5:$b$5"), 9, ورقة19.Range("b1") kh_cFormula Range("الاول!$n$5:$u$5"), 9, ورقة19.Range("b1") '============================================= kh_Err: kh_Application True If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear ' Else: MsgBox " تم نسخ المعادلات بنجاح", vbMsgBoxRight, "الحمدلله" End If End Sub ' MyRng : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة ' iRow : اول صف للبيانات ' Lastrow : آخر صف للبيانات Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long) Dim Col As Range Dim R As Long '======================== For Each Col In MyRng.Cells If Col.HasFormula Then For R = iRow To Lastrow With MyRng.Worksheet .Cells(R, Col.Column).FormulaR1C1 = Col.FormulaR1C1 .Cells(R, Col.Column).Value = .Cells(R, Col.Column) End With Next R End If Next '======================== Set Col = Nothing End Sub Sub kh_Application(ibol As Boolean) With Application .ScreenUpdating = ibol .Calculation = IIf(ibol, -4105, -4135) .EnableEvents = ibol End With End Sub Sub kh_Copy_Formula1() On Error GoTo kh_Err kh_Application1 False '============================================= kh_cFormula Range("الثانى!$b$5:$b$5"), 9, ورقة20.Range("b1") kh_cFormula Range("الثانى!$n$5:$u$5"), 9, ورقة20.Range("b1") '============================================= kh_Err: kh_Application1 True If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear ' Else: MsgBox " تم نسخ المعادلات بنجاح", vbMsgBoxRight, "الحمدلله" End If End Sub ' MyRng : الصف المخفي الذي يحوي المعادلات ملحوق باسم الورقة ' iRow : اول صف للبيانات ' Lastrow : آخر صف للبيانات Sub kh_cFormula1(MyRng As Range, iRow As Integer, Lastrow As Long) Dim Col As Range Dim R As Long '======================== For Each Col In MyRng.Cells If Col.HasFormula Then For R = iRow To Lastrow With MyRng.Worksheet .Cells(R, Col.Column).FormulaR1C1 = Col.FormulaR1C1 .Cells(R, Col.Column).Value = .Cells(R, Col.Column) End With Next R End If Next '======================== Set Col = Nothing End Sub Sub kh_Application1(ibol As Boolean) With Application .ScreenUpdating = ibol .Calculation = IIf(ibol, -4105, -4135) .EnableEvents = ibol End With End Sub استاذ ياسر آدي الكود والملف .. مبسوط ياعم عملت اللي عليا .. همتك بقى

عدد الصغوف او عدد الطلاب متغير

هذا هو الملف المطلوب الصف رقم 1000 به معادلات واطارات اريد نسخه بمعادلاته وتنسيقاته في من الصف ال11 وحتى نهايه العدد الموجود في الخليه B4 وشكرا لتوجيهاتكم يابو ضحكة جنان نسخ المعادلات والتنسيقات.zip

انت خلاص قررت ان الاخوة لا يلتفتوا الى موضوعي .. عرفني ايه الحكايه الله يسامحك

هذا الكود موجود بهذا الموضوع http://www.officena.net/ib/index.php?showtopic=58577&page=3 المشاركة 43

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