المســـاعدة في كــــود نســـخ ولصـــق

[أيمن ابراهيم]

السلام عليكم ورحمة الله وبركاتة

كل عام وانتم بخـــير بمناسبة شهر رمضان الكريم اعادة الله عليكم بكل خـــير

وبعد : المطلوب من السادة الاعضاء الكرام المساعدة في كتابة كود بالملف المرفق

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

لكم منى وافر التحية والاحترام

1.rar

[omar elhosseini]

الاخ أيمن ابراهيم

 ( ألن تحتاج الي رأس للشيت ايضا ( ال 9 صفوف في اول  الورقة ناجح

تم تعديل يونيو 11, 2016 بواسطه عمر الحسيني

[أيمن ابراهيم]

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

تم تعديل يونيو 11, 2016 بواسطه أيمن ابراهيم

[ياسر العربى]

تفضل اخي

1213123.rar

[أيمن ابراهيم]

13 دقائق مضت, ياسر العربى said:

تفضل اخي

1213123.rar

الشكر كل الشكر الاستاذ الفاضل ياسر العربي 

هذا  هو الملطوب كما اردت لك منى جزيل الشكر

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

2.rar

[ياسر العربى]

تفضل اخي ايمن

 

2.rar

[أيمن ابراهيم]

12 دقائق مضت, ياسر العربى said:

تفضل اخي ايمن

 

2.rar

اشــكرك شـــكراً جــــزيلاً اخــي الفـــاضل ياســر العـــربي 

تقـبل تحيــاتي لك من وافـــر التحــية وكل عــام وانتـــم بخـــــير

[ياسر العربى]

الحمد لله ان تم المطلوب

وكل عام وانتم بخير

تقبل تحياتي

[أيمن ابراهيم]

في ١١‏/٦‏/٢٠١٦ at 14:26, ياسر العربى said:

الحمد لله ان تم المطلوب

وكل عام وانتم بخير

تقبل تحياتي

الشكر لك اخى الفاضل ياسر على مجهوداتك لخدمة اعضاء المنتدى

عند وضع الكود في الشيت كنترول الرئيسي الكود يأخذ وقت طويل جداً عن تنفيذ الكود خارج الشيت كنترول الرئيسي 

برجاء توضيح  السبب في  عدم سرعة الكود داخل الشيت كنترول الرئيسي

تقبل تحياتي

[ياسر العربى]

اخي الكريم لقد قمت بتوسيع نطاق البيانات فوق 16 الف صف

ووقت نقل التذييل لم يتعدى ال16 ثانية لجهاز متوسط الامكانيات

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

السبب الاكيد كثرة المعادلات داخل المصنف والتنسيقات والكائنات

هعملك طريقة وتجربها

Sub RoundedRectangle3_Click()
    Dim last As Long
    Dim y As Long
    y = 40
 Application.Calculation = xlManual
    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
    Application.Calculation = xlAutomatic
    MsgBox "تم بحمد الله"
End Sub

ضع الكود دا وجرب كدا

[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
' ' ' ' ' ' ' ' ' ' ' '

اقتباس  (

الاستاذ الكريم ياسر العربي وضغت شرح لبعض الجمل لكودك الرائع ليكون مرجعا سهلا للاخوه

ارجو ان تكمل الشرح للجمل التي لم استطع شرحها )

 

[asdhamdey]

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

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

[ياسر العربى]

شرح الكود

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

 

[asdhamdey]

مش فاهم الرقم 36 الموجود بالكود وكذلك الرقم 30

[أيمن ابراهيم]

4 ساعات مضت, ياسر العربى said:

اخي الكريم لقد قمت بتوسيع نطاق البيانات فوق 16 الف صف

ووقت نقل التذييل لم يتعدى ال16 ثانية لجهاز متوسط الامكانيات

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

السبب الاكيد كثرة المعادلات داخل المصنف والتنسيقات والكائنات

هعملك طريقة وتجربها

Sub RoundedRectangle3_Click()
    Dim last As Long
    Dim y As Long
    y = 40
 Application.Calculation = xlManual
    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
    Application.Calculation = xlAutomatic
    MsgBox "تم بحمد الله"
End Sub

ضع الكود دا وجرب كدا

اخى الفاضل الاستاذ ياسر لك منى وافر التحية والاحترام 

لقد تم وضع الكود كما اشرت سيادتكم ولكن الكود يستغرق وقت كبير عن العادة نتيجة وجود خطأ ما 

مرسل اليكم الشيت للتجربة والتصحيح والتعديل

اسم المستخدم ayman   السري 2010

رابــــط خارجي للملف لعدم امكانية رفع الملف على المنتدى لكبر حجمه

http://3rbup.com/77ee97214877fd6a

 

[asdhamdey]

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

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

Sub printpreview1()
'كود معاينة طباعة مطاطي
Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).printpreview
End Sub

 

Sub print_2()
'كود طباعة مطاطي
Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).PrintOut
End Sub

 

[asdhamdey]

'كود معاينة طباعة
Sub printpreview()
ActiveWindow.SelectedSheets.printpreview
End Sub

 

الصفحات محميه نرجو فكها او ماهو الرقم السري

[أيمن ابراهيم]

منذ ساعه, asdhamdey said:

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

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

Sub printpreview1()
'كود معاينة طباعة مطاطي
Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).printpreview
End Sub

 

Sub print_2()
'كود طباعة مطاطي
Range("a4:aa" & Cells(Rows.count, "c").End(xlUp).Row).PrintOut
End Sub

 

اشكرك اخي الفاضل على اهتمامك 

كود معاينة الطباعة المطاطي وكود الطباعة المطاطي  من اعمال الاستاذ الكبير اسلام رجب له منا جزيل الشكر

بالنسبة لحماية الصفحات جميعها 2010  وهى موجودة بداخل الاكواد الموجودة بالشيت

تقبل تحياتي

 

[asdhamdey]

6 ساعات مضت, asdhamdey said:

مش فاهم الرقم 36 الموجود بالكود وكذلك الرقم 30

 

لماذا الرقم 36 بالذات والرقم 30 بالذات

[ياسر العربى]

10 ساعات مضت, أيمن ابراهيم said:

 

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

المهم عملت لك كود اخر نتحايل على الموضوع دا تفضل بدل الكود بهذا الكود

Sub Yasserelaraby()
    Dim last As Long, y As Long, x As Long, b As Long
    Dim bb As Long, zz As Long, vv As Long
    Application.ScreenUpdating = False
    last = ActiveSheet.Range("b6").End(xlDown).Row
    Range("b6:bx" & last).Copy: Range("b1000").PasteSpecial
    Range("b6:bx" & last).ClearContents
    zz = Application.WorksheetFunction.CountA(Range("b1000:b1800"))
    y = 29
    b = 1000
    bb = 6
    Do
        vv = Application.WorksheetFunction.CountA(Range("v6:v900"))
        If vv >= zz Then GoTo 0
        Range("b" & b & ":bx" & b + y).Copy: Range("b" & bb & ":bx" & bb).PasteSpecial
        Application.CutCopyMode = False
        last = ActiveSheet.Range("b6").End(xlDown).Row
        Sheets("كعب الشيت").Rows("2:7").Copy
        ActiveSheet.Rows(last + 1).PasteSpecial
        Application.CutCopyMode = False
        b = b + 30
        bb = bb + 36
    Loop
0   last = ActiveSheet.Range("b1000").End(xlDown).Row
    Range("b1000:bx" & last).Clear
    Application.ScreenUpdating = True
    MsgBox "تم بحمد الله ادراج كعب الشيت بجميع الصفحات "
End Sub

جرب وبلغني

تقبل تحياتي

9 ساعات مضت, asdhamdey said:

 

لماذا الرقم 36 بالذات والرقم 30 بالذات

رقم 36 مجموع عدد الطلاب ال30 بالاضافة الى 6 عدد صفوف كعب الشيت لكل صفحة

تحياتي

[ياسر العربى]

10 ساعات مضت, أيمن ابراهيم said:

 

هيقابلك مشكلة التنسيقات الكتير داخل كعب الشيت وهتلاقي الصفحات الكعب الخاص بها مليان بالالوان

تفضل ملفك مرفق بعد تعديل التنسيق الخاص بالكعب ليتم نسخ الكعب بالتنسيق الخاص به

فيصبح بدون الوان

اتمنى ان يكون تم المطلوب

تقبل تحياتي

ايمن النهائي.rar

 

[أيمن ابراهيم]

استاذى الفاضل ياسر العربي اعلم بأنني اتعبتك معي في هذا الموضوع ولكن هذا عشمنا في حضرتك

الكود الجديد يعمل بسرعة وكفاءة ولكن في الشيت الرئيسي

المفروض اولاً ترحيل نتيجة الطلاب من الشيت الرئيسي الى شيتات التبييض من خلال زر ترحيل تبييض الموجود باعلى الشيت الرئيسيي

ثم الانتقال الى شاشة تبييض النتيجة من خلال الزر تبييض النتيجة الموجود بالصفحة الرئيسية 

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

وهكذا في باقى الشيتات المرحل اليها نتائج الطلاب لتجهيزها للطباعة 

تقبل تحياتي وكل عام وانتم بخـــــير

تم تعديل يونيو 15, 2016 بواسطه أيمن ابراهيم

[ياسر العربى]

تفضل اخي الكريم تم تطبيق الكود على ناجح مدرسة وراسب مدرسة
جرب وبلغني

وكل عام وانتم بكل صحة وعافية

ايمن النهائي.rar

[أيمن ابراهيم]

7 ساعات مضت, ياسر العربى said:

تفضل اخي الكريم تم تطبيق الكود على ناجح مدرسة وراسب مدرسة
جرب وبلغني

وكل عام وانتم بكل صحة وعافية

ايمن النهائي.rar

اشكرك شكراً جزيلاً استاذي ياسر 

هذا هو المطلوب بالضبط 

جعلة الله في ميزان حسناتك 

تقبل تحياتي وكل عام وانتم بخــــير

[asdhamdey]

 

في ١٥‏/٦‏/٢٠١٦ at 02:25, أيمن ابراهيم said:

بالنسبة لحماية الصفحات جميعها 2010  وهى موجودة بداخل الاكواد الموجودة بالشيت

في ١٤‏/٦‏/٢٠١٦ at 20:54, أيمن ابراهيم said:

اسم المستخدم ayman   السري 2010