اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


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

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

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

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

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

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


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

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

رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

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

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

المطلوب 

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

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

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

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

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

 

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

 

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

رابط هذا التعليق
شارك

هل تقصد أن يكون الترحيل من ورقة العمل 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

 

رابط هذا التعليق
شارك

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

 

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

 

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

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

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

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

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

 

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

رابط هذا التعليق
شارك

استاذي 

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

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

عندما احدد من 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

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

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

 

 

 

تم تعديل بواسطه ابومحمد2017
رابط هذا التعليق
شارك

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

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

 If FS.Name <> "data" Then

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

رابط هذا التعليق
شارك

 

 

 

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

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

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

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

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

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

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

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

 

 

 

تم تعديل بواسطه ابومحمد2017
رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

 

 

 

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

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

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

منذ ساعه, ياسر خليل أبو البراء 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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

وادعو الله ان 

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

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

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

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

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

 

محمية.JPG

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information