اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر

ارجو معاينة الملف المرفق 

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

مطلوب.rar

قام بنشر

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Target.Column <> 3 Then Exit Sub
    
    Select Case Target.Value
    
    Case Is = 1
        Target.EntireRow.Copy Sheets("الصف الاول").Range("A1000").End(xlUp).Offset(1, 0)
    
    Case Is = 2
        Target.EntireRow.Copy Sheets("الصف الثانى").Range("A1000").End(xlUp).Offset(1, 0)
       
    
    Case Is = 3
        Target.EntireRow.Copy Sheets("الصف الثالث").Range("A1000").End(xlUp).Offset(1, 0)
       
    Case Is = 4
        Target.EntireRow.Copy Sheets("الصف الرابع").Range("A1000").End(xlUp).Offset(1, 0)
       
     Case Is = 5
        Target.EntireRow.Copy Sheets("الصف الخامس").Range("A1000").End(xlUp).Offset(1, 0)
       
    
    End Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

بعد اذن الاستاذ سليم   هذه الاضافة

أخى الكريم ضع الكود التالى فى حدث الورقة  بمجرد ادخال رقم الصف فى العمود c يتم الترحيل مباشرة

 

 

  • Like 1
قام بنشر

عذرا نسيت انك مرقم التلاميذ فى كل الاوراق   جرب ده  عشان الترقيم


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Target.Column <> 3 Then Exit Sub
    
    Select Case Target.Value
    
    Case Is = 1
        Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الاول").Range("B1000").End(xlUp).Offset(1, 0)
    
    Case Is = 2
        Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الثانى").Range("B1000").End(xlUp).Offset(1, 0)
          
    Case Is = 3
        Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الثالث").Range("B1000").End(xlUp).Offset(1, 0)
    
    Case Is = 4
    Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الرابع").Range("B1000").End(xlUp).Offset(1, 0)
        Target.EntireRow.Copy Sheets("الصف الرابع").Range("A1000").End(xlUp).Offset(1, 0)
       
     Case Is = 5
         Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الخامس").Range("B1000").End(xlUp).Offset(1, 0)
      
    End Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

  • Like 1
قام بنشر
26 دقائق مضت, مختار حسين محمود said:

 

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

قام بنشر

استاذنا الكريم  والكبير مختار حسين محمود

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

مطلوب 22.rar

3 دقائق مضت, مختار حسين محمود said:

حضرتك هتكمل بكود الأستاذ سليم و لا الكود الأخير

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

قام بنشر
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

With Application
            .ScreenUpdating = False
           .DisplayAlerts = False
End With
   
If Target.Column <> 3 Then Exit Sub
    
    Select Case Target.Value
    
    Case Is = 1
        Target.Offset(0, -1).Resize(, 7).Copy
        With Sheets("c1").Range("B1000").End(xlUp).Offset(1, 0)
             .PasteSpecial xlPasteValues
             .PasteSpecial xlPasteColumnWidths
        End With
        
    Case Is = 2
        Target.Offset(0, -1).Resize(, 7).Copy
        With Sheets("c2").Range("B1000").End(xlUp).Offset(1, 0)
             .PasteSpecial xlPasteValues
             .PasteSpecial xlPasteColumnWidths
        End With
        
    Case Is = 3
        Target.Offset(0, -1).Resize(, 7).Copy
        With Sheets("c3").Range("B1000").End(xlUp).Offset(1, 0)
             .PasteSpecial xlPasteValues
             .PasteSpecial xlPasteColumnWidths
        End With
    
    Case Is = 4
    Target.Offset(0, -1).Resize(, 7).Copy
        With Sheets("c4").Range("B1000").End(xlUp).Offset(1, 0)
             .PasteSpecial xlPasteValues
             .PasteSpecial xlPasteColumnWidths
        End With
    
       
     Case Is = 5
         Target.Offset(0, -1).Resize(, 7).Copy
        With Sheets("c5").Range("B1000").End(xlUp).Offset(1, 0)
             .PasteSpecial xlPasteValues
             .PasteSpecial xlPasteColumnWidths
        End With
        
    End Select

   With Application
            .CutCopyMode = False
            .ScreenUpdating = True
           .DisplayAlerts = True
   End With

End Sub

ده عشان الطلب الاول نسخ القيم وعرض الأعمدة فقط

الطلب التانى  عايز  تمسح  العمود C   وكل البيانات فى كل الأوراق  مش كده ولا تقصد حاجة تانى ؟

 

قام بنشر

الطلب التانى حضرتك 

عند حذف الارقام من العمود(c) فى الشيت data يتم مسح وازالة البيانات التى تم نسخها فى بقية الاوراق 
او عند تغيير  الرقم تتم الازالة من الورقة التى كان بها النسخ السابق ويتحول للورقة الجديدة

ولحضرتك جزيل الشكر 

قام بنشر

حضرتك غيرت  فى ورقة DATA   أعمدة جديدة

لذا ينبغى عليك أن تعديل فى الأوراق المرحل اليها لتتطابق تماما مع ورقة DATA    تجنبا لحدوث أخطاء

هذا ما لاحظته فى المرفق الاخير

  • Like 1
قام بنشر
13 دقائق مضت, مختار حسين محمود said:

حضرتك غيرت  فى ورقة DATA   أعمدة جديدة

لذا ينبغى عليك أن تعديل فى الأوراق المرحل اليها لتتطابق تماما مع ورقة DATA    تجنبا لحدوث أخطاء

هذا ما لاحظته فى المرفق الاخير

تم استاذى الفاضل 
والحمد لله 
وشاكر لمجهود سيادتك

قام بنشر

ضع الكود التالى فى مديول جديد 

الكود لمسح النطاق من الخلية a4 الى آخر خلية فى العمود j  فى كل الاوراق  

و أؤكد مرة أخرى لابد من تتطاق جميع الأورارق

Option Explicit

Sub delallData()
Dim ws As Worksheet
On Error Resume Next
Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
     With ws
       .Activate
       .Range(Cells(4, "A"), Cells(Rows.Count, "J")).ClearContents
     End With
Next ws
On Error GoTo 0
Sheets("data").Activate
Application.ScreenUpdating = True

End Sub

تحياتى

  • Like 1
قام بنشر
27 دقائق مضت, مختار حسين محمود said:

 جرب ترحيل البيانات الى كل الأوراق 

و شيل السطر ده  و جرب الكود

هل تقصد أن السطر ضروري استخدامه ؟ لو كان ضروري فأكيد هناك طريقة تجعلك تستغنى عنه

لا يحبذ استخدام Select و Activate في كتابة الكود إذ أنه يسبب بطء في التنفيذ

  • Like 3
قام بنشر
13 دقائق مضت, ياسر خليل أبو البراء said:

لا يحبذ استخدام Select و Activate في كتابة الكود إذ أنه يسبب بطء في التنفيذ

أدرك ذلك ولكن

بدون السطر ده  الكود لن يعمل الا على الورقة الاولى فقط

و السطر التالى له مع الحلقة التكرارية يستلزم  بالضرورة  تنشيط الأوراق ورقة ورقة لاتمام الحلقة التكرارية

وهو فيه أكيد طرق أخرى لكن أخى معلم ابتدائى أخد منى  النهردة  كل تركيزى الله يبارك له :biggrin:

 

  • Like 1
قام بنشر

جرب الكود بهذا الشكل (لم أختبر الكود) فقط قمت بإضافة نقطة قبل كلمة Cells للإشارة إلى ورقة العمل التي سيكون عليها الدور في الحلقة التكرارية دون تنشيط الورقة

Sub DelAllData()
    Dim Ws As Worksheet
    
    Application.ScreenUpdating = False
        For Each Ws In ThisWorkbook.Worksheets
            With Ws
                .Range(.Cells(4, "A"), .Cells(Rows.Count, "J")).ClearContents
            End With
        Next Ws
        
        Sheets("Data").Activate
    Application.ScreenUpdating = True
End Sub

 

  • Like 2
قام بنشر

قمة الروعة 
انا فى قمة المتعة فى مقعد المتفرج على العمالقة 
بصراحة متعتى بهذا السجال الجميع تفوق اى متعة قد اصل اليها 

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

  • Like 1
قام بنشر

أخي الغالي مختار

كل الحكاية إنك مش مركز ساعتها بس ..وبعدين أنا متعلم مثلي مثلك لا أستاذ ولا حتى مساعد أستاذ

 

أخي الكريم المعلم الابتدائي

جزيت خيراً بمثل ما دعوت لنا ، ووفقنا الله وإياكم

هلا غيرت اسم الظهور ليعبر عن شخصكم الكريم ، فالمنتدى أسرة واحدة والجميع يعرف الجميع باسمه ولقبه

تقبلوا تحياتي

قام بنشر
6 ساعات مضت, ياسر خليل أبو البراء said:

أخي الغالي مختار

كل الحكاية إنك مش مركز ساعتها بس ..وبعدين أنا متعلم مثلي مثلك لا أستاذ ولا حتى مساعد أستاذ

 

أخي الكريم المعلم الابتدائي

جزيت خيراً بمثل ما دعوت لنا ، ووفقنا الله وإياكم

هلا غيرت اسم الظهور ليعبر عن شخصكم الكريم ، فالمنتدى أسرة واحدة والجميع يعرف الجميع باسمه ولقبه

تقبلوا تحياتي

أخوك جمعة ذكى على 
محافظة أسوان 
مدير مدرسة ابتدائى 
والعمر 46 سنة 
ولى عظيم الشرف ان اكون بين كوكبة من اروع العمالقة للتعلم منهم 
تحياتى للجميع ولكم جزيل التقدير والعرفان 
صفحتى على الفيس بوك 
https://www.facebook.com/gomaazaki

قام بنشر
3 ساعات مضت, ياسر خليل أبو البراء said:

تشرفنا بيك أستاذنا الفاضل ذكي جمعه وأهلاً بيك في أسرة أوفيسنا

تقبل تحياتي

لكم تحياتى ايها الأفاضل 
جمعة ذكى ــ استاذنا ــ وليس ذكى جمعة هههههههههههههههههه

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

 

ترحيل.rar

قام بنشر

أعتذر إليك عن الخطأ الذي أوردته في اسمك ..أخي الفاضل جمعه ذكي

بالنسبة للتعامل مع موضوع الترحيل وخلافه أفضل التعامل بالأكواد إذ أن المعادلات قد تحتوي على معادلات صفيف وهي مع كثرة البيانات تسبب ثقل في الملف وبطء في التعامل مع الملف بشكل ملحوظ

تقبل وافر تحياتي

  • Like 1

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information