كيف اكرر كود الترحيل في جميع الاوراق ضيف جديد

[ابومحمد2017]

كيف اكرر كود الترحيل في جميع الاوراق ضيف جديد

السلام عليكم
وكل عام والجميع بخير

امل المساعدة لدي شيت داتا والكود يعمل في شيت رقم 1 واريد ان اكرر الكود في الشيتات الباقية

يعني اذا تم الترحيل يضيف كلمة مرحل تم لا يكرر الترحيل 

علما اني سوف انقله لملف اخر ملي بالاكواد 

ولكم جزيل الشكر

المطلوب تكرار الكود في جميع الاوراق مع كلمه مرحل.rar

[ابومحمد2017]

تكرار الكود فقذ في جميع الاوراق مع كلمه مرحله 

 

لكي لا يتم الترحيل اكثر من مره

 

 

بنتظر من يتكرم بالمساعدة 

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

[ابومحمد2017]

للرفع

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

أخي الكريم أبو محمد

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

اطلعت على ملفك ووجدت كود يفي بالغرض .. ويفعل ما طلبته

هلا وضحت المشكلة بشكل أعمق

[ابومحمد2017]

استاذي الفاضل 

اطرح سؤالي بعدان بحث وحاولت كثيرا دون فائدة 

المطلوب 

تعديل على كود الترحيل 
ليعمل في جميع الاوراق 

هو الان يعمل في شيت 1 ويرحل الى الشيت 2 المسمى DATA 

ولا يعمل زر الترحيل في شيت 3 و 4 و5 و6 و7… ..

بحيث يكون شيت 2 هو الداتا و يرحل اليه من كل شيت 

علما اني سوف انقله لملف اخر ملي بالاكواد 

 

ولك جزيل الشكر والتقدير والعرفان 

 

*اعتذر عن طرح المشكله مرة اخر هنا لاني لم استطع شرحها بشكل الصحيح المره الاول * 

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

هل تقصد أن يكون الترحيل من ورقة العمل data إلى بقية أوراق العمل كلها بالمصنف ..أم أن هناك أوراق عمل سيتم استثنائها من عملية الترحيل؟

[ابومحمد2017]

اقصد العكس استاذي الفاضل 

 

ترحيل من الاوراق بالمصنف الي ورقة العمل DATA

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

جرب الكود التالي

Sub TARHEEELL()
    Dim FS As Worksheet, TS As Worksheet
    Dim R, ER1, ER2
    
    Set TS = Sheets("data")
    ER2 = TS.Range("A55555").End(xlUp).Row + 1

    Application.ScreenUpdating = False
        For Each FS In ThisWorkbook.Worksheets
            If FS.Name <> "data" Then
                For ER1 = 3 To FS.Cells(Rows.Count, 1).End(xlUp).Row
                    If FS.Cells(ER1, 1) <> "" And FS.Cells(ER1, 14) <> "مرحل" Then
                        TS.Cells(ER2, 1).Resize(1, 13).Value = FS.Cells(ER1, 1).Resize(1, 13).Value
                        FS.Cells(ER1, 14) = "مرحل"
                        ER2 = ER2 + 1
                    End If
                Next ER1
            End If
        Next FS
    Application.ScreenUpdating = True
End Sub

 

[ابومحمد2017]

الله يفتح عليك 

 

ماشاء الله تبارك الله عليك 

 

ولكن استاذي الفاضل الكريم 

اعذرني لو اثقلت عليك

كيف يرحل نطاق معين من باقي الاوراق الى DATA

نطاق محدد هو A7 الى m25 في كل ورقة هو الذي يرحل فقط

هذا النطاق فقط يرحل الى ورقة DATA

 

ولك كل الشكر والتقدير 

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

استبدل هذا الجزء 

FS.Cells(Rows.Count, 1).End(xlUp).Row

بالرقم 27

[ابومحمد2017]

اعذرني استاذي 

 

هل اضع رقم 27 فقط مكان السطرين

وماذا يعني 27 

 

ولك جزيل الشكر 

[ابومحمد2017]

 

 

الله يفتح عليك 

ماشاء الله تبارك الله عليك 

استاذي الفاضل الكريم 

الف الف الف شكر

لك كل الشكر والتقدير   

 

 

 

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

الحمد لله الذي بنعمته تتم الصالحات

لا تنسانا بدعوة بظهر الغيب

[ابومحمد2017]

استاذي 

الله يجزاك الجنة ووالديك وذريتك ومن تحب 

و ارجوا ان يتسع صدرك لي

عندما احدد من 6 الى 23  لكي يرحل وسطه النطاق حسب مافهمت منك

استبدل هذا الجزء 

FS.Cells(Rows.Count, 1).End(xlUp).Row

بالرقم 27

 سجل اعجاب بهذا

•         الذي حدث
•               انه يكرر النقل مرتين 
• بدل ان يرحل 18 سطر يرحل 36
• ومرات اربعين سطر 
• يعني يكررهم مرتين وشوي

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

 

**وحفظت الملف بصيغة ميكرو**

ووجدت هذا الكود في الملف الاساس في ورقة الداتا

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = True
End Sub

نقلته الى ملفي شيت الداتا ولم يتغير شي 

علمنا ان ملفي فيه اكواد مختلفة

 

 

 

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

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

عند نقل الكود يراعى أن يتم استثناء أوراق العمل التي لن تقوم بالترحيل منها

مثل هذا السطر ويمكن إضافة أوراق أخرى للاستثناء من خلال استخدام كلمة AND لإضافة شروط جديدة

 If FS.Name <> "data" Then

بالنسبة للكود في حدث تغير ورقة العمل لا أرى أن له داعي ويمكن الاستغناء عنه

[ابومحمد2017]

 

 

 

استاذي الفاضل الكريم 

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

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

نظام سند صرف متسلسل هو رقم الشيت  

دون ان اظطر لدخول وتغيير اسم الصفحة كل مرة انشاء ورقة عمل من محرر الاكواد

اريد الكود يرتبط تلقائي بتفس الصفحة التي اظغط منها 

ويتكرر في جميع الاوراق ولكن كل ورقة ترحل لوحدها

ولك كل الشكر والتقدير   

 

 

 

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

[ابومحمد2017]

 

للرفع

بتظارك استاذ ي

 

ياسر خليل ابو البراء

• .

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

[حازم محي الدين]

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

فبرجاء اصلاح هذه الجزء ولكم جزيل الشكر لأنني أعمل عليه الأن في كنترول المدرسة 

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

هل المطلوب الترحيل من جميع الأوراق لورقة data مرة واحدة أم كل ورقة ستكون بشكل مستقل؟

لم أفهم المطلوب بشكل جيد ... ولا أدري ما المشكلة معك الآن بشكل دقيق؟

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

إذا كانت المشكلة في ملفك الأصلي فقم بإرفاق الملف للإطلاع عليه لمعرفة سبب المشكلة

[ابومحمد2017]

 

 

 

استاذي الفاضل الكريم 

اولا اعتذر اني لم استطع شرح المشكلة بشكل واضح 

ثانيا المشكلة هي حسب ماقلت انت الان 

منذ ساعه, ياسر خليل أبو البراء said:

هل المطلوب الترحيل  لورقة data  من كل ورقة ستكون بشكل مستقل؟

المطلوب الترحيل من كل ورقة ستكون بشكل مستقل؟

لك كل الشكر والتقدير   

 

 

 

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

جرب الكود التالي

Sub TARHEEELL()
    Dim FS As Worksheet, TS As Worksheet
    Dim R, ER1, ER2
    
    Set TS = Sheets("data")
    Set FS = ActiveSheet
    ER2 = TS.Range("A55555").End(xlUp).Row + 1

    Application.ScreenUpdating = False
        If FS.Name <> "data" Then
            For ER1 = 3 To FS.Cells(Rows.Count, 1).End(xlUp).Row
                If FS.Cells(ER1, 1) <> "" And FS.Cells(ER1, 14) <> "مرحل" Then
                    TS.Cells(ER2, 1).Resize(1, 13).Value = FS.Cells(ER1, 1).Resize(1, 13).Value
                    FS.Cells(ER1, 14) = "مرحل"
                    ER2 = ER2 + 1
                End If
            Next ER1
        End If
    Application.ScreenUpdating = True
End Sub

 

[ابومحمد2017]

استاذي الكريم 
ياسر خليل أبو البراء

اشكرك على تجاوبك وتعاونك

وادعو الله ان 

يبيض وجهك
و يشرح صدرك
و يرفع قدرك
و يعلي كلمتك
و يوفقك في حياتك
و يسعدك بعد مماتك
و يقضي عنك دينك
و يوسع في رزقك
و يبارك لك في يومك
و يجعل محبتك في قلوب عباده
و يسخر لك من تعرف ومن ﻻتعرف
و يجعلك مبارك في الدنيا 
و مغفوراً ذنبك في الآخرة
و يحميك من عين الحاسدين 
و من نظرات الشياطين 
و يرزقك برزق ليس له حدود
و يسخر لك كل الجنود
و يهدي بالك 
و يريح قلبك
و يغفر لك كل خطيئة
علمت بها أو لم تعلم بها
و أسأل الله الكريم
أن يرزقك الفردوس الاعلى من الجنة 
و أسأله أن يعيذك من جهد البلاء 
و درك الشقاء 
و سوء القضاء
و شماتة اﻷعداء
كما أسأله أن يعيذك 
من زوال نعمته
و من تحول عافيته
و فجاءة نقمته
و جميع سخطه
و أسأله أن يرضى عليك 
رضاً ﻻ يعقبه سخط  
والله يجزاك الجنة ووالديك وذريتك ومن تحب 
انت وانا وجميع المسلمين
اللهم آمين
و صل اللهم على سيدنا محمد و على آله وصحبه وسلم تسليمآ كثيرآ

 

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

بارك الله فيك أخي العزيز أبو محمد وجزيت خيراً على دعائك الطيب المبارك ..

وإن شاء الله لك بمثله وزيادة

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

[ابومحمد2017]

استاذي الكريم 
ياسر خليل أبو البراء

وجهتني مشكلة عند الترحيل الى شيت الداتا وهي محمية

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

فما الحل استاذي

 

[ابومحمد2017]

 

للرفع

بتظاركم استاذ تي

 

 

• گ