ناصر سعيد

الاستاذ ياسر خليل ارجو تدخلك في موضوع البرجرس بار الخاص بحبيبك

تقبل عذري واسفي اخي الكريم ياسر

Sub Tarhil_Ragab() 'تعريف المتغيرات Dim Sh As Worksheet Dim strSh As String Dim I As Long Dim AA As Long 'سطر لإيقاف تحديث الشاشة Application.ScreenUpdating = False 'مسح محتويات النطاق في ورقة العمل ناجح Sheets("ناجح").Range("A12:X1000").ClearContents 'مسح محتويات النطاق في ورقة العمل دور ثان Sheets("دور ثان").Range("A12:X1000").ClearContents 'مسح محتويات النطاق في ورقة العمل راسب Sheets("راسب").Range("A12:X1000").ClearContents 'بدء التعامل مع ورقة العمل الأولى التي تعتبر الورقة الرئيسية With Sheet1 '[Y] حلقة تكرارية بدايةً من الصف الـ 12 وحتى آخر صف به بيانات بالاعتماد على العمود For I = 12 To .Cells(10000, "Y").End(xlUp).Row '[Y] تعيين قيمة المتغير ليساوي قيمة الخلية في الصف المحدد في العمود 'ففي أول حلقة تكرارية سيكون الصف هو رقم 12 [I] المقصود بالصف المحدد الصف الذي يحمل قيمة المتغير 'وفي الحلقة التالية سيكون الصف رقم 13 وهكذا مع كل حلقة تكرارية يتغير الصف strSh = .Cells(I, "Y").Value 'تعيين المتغير ليساوي آخر صف في الورقة التي سيتم الترحيل إليها 'أو يمكنك القول معرفة رقم صف أول صف فارغ AA = Sheets(strSh).Cells(10000, 2).End(xlUp).Row + 1 'إذا كان المتغير أقل من 12 الذي من المفترض أنه صف البداية لعمليات الترحيل فإنه يتم تعيين المتغير ليساوي 12 If AA < 12 Then AA = 12 'في حالة حدوث خطأ يتم تجنبه بهذا السطر On Error Resume Next 'نسخ النطاق في الصف المحدد من العمود الثاني إلى العمود الرابع والعشرون .Range(.Cells(I, "B"), .Cells(I, "X")).Copy 'لصق النطاق المنسوخ إلى ورقة العمل المناسبة واللصق يكون لصق قيم فقط Sheets(strSh).Range("B" & AA).PasteSpecial xlPasteValues 'إلغاء خاصية النسخ واللصق Application.CutCopyMode = False 'هذا السطر يقوم بترقيم الصف الذي تم ترحيله في الورقة الهدف 'حيث يعتمد على إنقاص 11 من رقم الصف الحالي 'فإذا كان الصف الحالي هو رقم 12 ألا وهو رقم البداية فإن الرقم 'المسلسل سيكون 12 - 11 أي سيكون الرقم المسلسل 1 Sheets(strSh).Cells(AA, "A").Value = Sheets(strSh).Cells(AA, "A").Row - 11 'الانتقال للصف التالي في الحلقة التكرارية Next I 'حلقة تكرارية لكل أوراق العمل لتحديد الخلية الأولى في ورقةالعمل For Each Sh In ThisWorkbook.Worksheets Application.Goto Sh.Range("A1") Next Sh 'تنشيط ورقة العمل الأولى .Activate 'انتهاء التعامل مع ورقة العمل الأولى End With 'سطر لإعادة تفعيل اهتزاز الشاشة Application.ScreenUpdating = True 'إظهار رسالة تفيد بانتهاء عمل الكود MsgBox "تم الفصل بنجاح", 64 End Sub حتى يكثر الدعاء الطيب للاستاذ الكبير ياسر حليل

اين الاحبه حفظهم الله ورعاهم

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

السلام عليكم ورحمة الله الاخوه الكرام عند تنفيذ بغض الاكواد تأخذ وقت يعني بطيئه عايز برجرس بار يرتبط باي كود عند تنفيذ الكود يكون فيه عداد 1% و 2% وهكذا حتى ينتهي الى 100%

كود روعه .. ربنا يحفظك يا استاذ ياسر خليل

الأستاذ الكبير ياسر خليل جزاك الله كل خير

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

تحيه للاستاذ الكبير ياسر خليل جزاك الله كل خير ..

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

كودك الخاص بنسخ الصفوف به عدد 2 SUB وليست sub واحده

هل يمكن ان تفرد لنا درسا خاصا بكيفية ربط فورمه بكود

اسم الاجراء الفرعي هو الاسم اللي بعد كلمة sub لان ارى بعض الاكواد فيها كلمة sub واحدة ... هل فهمي صحيح

الاستاذ الكبير ياسر عندي سؤال هل عندما نريد ان يعمل اي كود مع الفورمه الموجوده حاليا نضع الفورمه الموجوده بالملف مع كودها الخاص بها ونضيف جملة Call DoIt ونضع الكود المطلوب ربطه بها في موديول هكذا يتم الربط هل فهمي لها صح

الاستاذ الكبير ياسر جزاك الله كل خير وبارك فيك كودك راااائع ادراج صفوق بالفورمه.rar

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

الاستاذ الكبير ياسر جزاك الله خيرا وهذه هي الجزئيه التي غيرتها وضبطط lngRow = rngEnd.Row - 1 لكن لايتم مسح كل التنسيقات في الصفوف المزاله يعني الصفوف تم ازالة خوطها فقط واحنا عايزين ازاله الصفوف بكامل محتوياتها

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

الاستاذ الكبير ياسر لم الحظ اي تغيير في الكود يعني لم يزل الصفوف ايه رايك لو ان الكود نفس فكره كود اضاقه صفوف هيكون ازاله صفوف بعدد محدد يعني هاتكتب عدد الصفوف الذي نريد ازاله الصفوف

ربنا يجزيك الخير ... تمام التمام تاكدت ياباشا انك متواضع بعمل الكود تمام التمام ............. لو نضيف جزئيه صغيره وهي ان يمسح الكود اولا الصفوف الموجوده تم يتسخ العدد الموجود ليه ؟ افرض الكود تم نسخه لعدد 200 وعايزين نغير العدد الى مثلا 150 ... اذن يجب ان يتم المسح اولا ثم تنفيذ النسخ بعد ذلك جزاك الله خير

الاستاذ الكبير ياسر السلام عليكم ورحمة الله انت متواضع بارك الله فيك هذا هو الملف ادراج بالفورمه.rar

وعندما وضعت End If ظهرت هذه الرساله

الاستاذ الكبير ياسر غدم معرفتي بالاكواد يجغلني في هذا الموقف ولم اقل ابدا ان الخطأ منكم ظهرت هذه الرساله والكود المستخدم هاهو Private Sub CommandButton1_Click() If TextBox1.Text = Sheets("بيانات الطلبة").Range("Z1") Then Me.Hide TextBox1.Text = "" MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب" Application.ScreenUpdating = False End Sub Sub CopyRow(sSheet As String, sRow As Long, LC As Long) Dim Ws As Worksheet Dim cnt As Long On Error Resume Next Set Ws = Sheets(sSheet) On Error GoTo 0 If Ws Is Nothing Then MsgBox "Sheet " & sSheet & " Doesn't Exist In The Workbook.", vbExclamation, "Sheet Not Found!" Exit Sub End If cnt = Sheets("بيانات المدرسة").Range("B10").Value Ws.Range(Ws.Cells(sRow, 1), Ws.Cells(sRow, LC)).Copy Ws.Range("A" & sRow).Resize(cnt + 1).PasteSpecial xlPasteAll On Error Resume Next Ws.Range("A" & sRow + 1).Resize(cnt, LC).SpecialCells(xlCellTypeConstants, 3).ClearContents Application.CutCopyMode = False End Sub Sub DoIt() CopyRow "بيانات الطلبة", 7, 19 CopyRow "إنجاز1", 7, 15 CopyRow "رصد الترم الأول", 7, 29 CopyRow "أعمال السنة", 7, 15 CopyRow "رصد الترم الثانى", 7, 102 CopyRow "كنترول شيت", 12, 114 End Sub Call DoIt Application.ScreenUpdating = True Unload Me Else MsgBox "عفوا كلمة المرور خاطئة و لن يتم تنفيذ المطلوب" TextBox1.Text = "" TextBox1.SetFocus End If End Sub Private Sub TextBox1_Change() End Sub Private Sub UserForm_Click() End Sub

الاستاذ الكبير ياسر السلام عليكم ورحمة الله اجهدتني هذه الاضافه وتظهر هذه الرساله