نسخ بيانات من صفحة لعدة صفحات بشرط

[جمعة ذكى]

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

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

مطلوب.rar

[سليم حاصبيا]

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

 

مطلوب salim.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 يتم الترحيل مباشرة

 

 

[مختار حسين محمود]

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

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

 

[جمعة ذكى]

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    تجنبا لحدوث أخطاء

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

[جمعة ذكى]

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

تحياتى

[ياسر خليل أبو البراء]

أخي الحبيب مختار ليه السطر ده ..

.Activate

 

أطن فهمتني ..

[مختار حسين محمود]

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

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

[ياسر خليل أبو البراء]

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

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

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

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

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

[مختار حسين محمود]

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

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

أدرك ذلك ولكن

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

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

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

 

[ياسر خليل أبو البراء]

جرب الكود بهذا الشكل (لم أختبر الكود) فقط قمت بإضافة نقطة قبل كلمة 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

 

[مختار حسين محمود]

رااااااااااائع 

عندى حق أنا لما بقول إنك أستاذى ولا  لأ ؟

[جمعة ذكى]

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

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

[ياسر خليل أبو البراء]

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

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

 

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

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

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

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

[جمعة ذكى]

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

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

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

 

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

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

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

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

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

[ياسر خليل أبو البراء]

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

تقبل تحياتي

[جمعة ذكى]

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

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

تقبل تحياتي

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

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

 

ترحيل.rar

[ياسر خليل أبو البراء]

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

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

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