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

ترحيل من الدفتر الى ورقة المحافظة


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

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

الساجة الأفاضل اعضاء المنتدى

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

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

الأخ الكريم بدء الكلام بالسلام أفضل .. السلام عليكم

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

http://www.officena.net/ib/index.php?showtopic=60147

حتى  تهتدى لإجابة و حل لمسئلتك دون الخوض فى الكثير من النقاش.. عليك برفع ملف للتطبيق عليه حتى يأتى متماشيا مع طبيعة ملفك الأصلى.. أى ليس شرطا ان يحتوى على بيانات حقيقية و لكن على الأقل صورة مشابة للأصلى من حيث الأعمدة و الصفوف و رؤوس الأعمدة و ترتيبها ( بين الدفتر الأساسى و شيتات المحافظات ).. بدأت بساجة و انتهيت بمسخ ( اعرف انها سادة و نسخ .. و لكن الحمد لله اننى لست فى مزاج رائق للقفشة حتى أقتنصها .. بل اشرت اليها فقط ).. دمت بخير و أعزك الله

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

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

عفوا الأساتذة الكرام 

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

request.zip

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

أخي الكريم عبد الله شيخون

إليك الكود التالي

Sub TarhilByRegion()
    Dim WS As Worksheet
    Dim Cell As Range
    Dim strSheet As String
    Dim LR As Long
    
    Set WS = Sheets("الدفتر")
    Application.ScreenUpdating = False
        For Each Cell In WS.Range("J3:J" & WS.Cells(Rows.Count, "J").End(xlUp).Row)
            strSheet = Cell.Value
            On Error GoTo 1
            LR = IIf(Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row < 3, 3, Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row + 1)
            Cell.Offset(, -8).Copy
            Sheets(strSheet).Range("D" & LR).PasteSpecial xlPasteValues
            Cell.Offset(, -6).Resize(, 8).Copy
            Sheets(strSheet).Range("E" & LR).PasteSpecial xlPasteValues
1       Next Cell
    WS.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" إذا أعجبك الحل

تقبل تحياتي :fff: :fff: :fff:

 

Transfer Data By Region YasserKhalil.rar

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

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

رمضان كريم

كواد مميز ورائع كما تعودنا منكم. الأساتذة الأفاضل

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

وهل يمكن ان يتعطل هذا الكود مع ان الأعداد تتجاوز الألف

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

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

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

السلام عليكم ورحمة الله وبركاته أخي وحبيبي في الله أبو البراء برأك الله من كل مكروه وجعلك الله ممن يأتي ربه بقلب سليم

 

وأنا أيضاً أعجبني هذا ولكن لا يمكنني تحديد كأفضل إجابة هههههه

 أحببت استعمال الوجوه التعبيرية فوجدتها أقل من مقامك وخصوصاً تلك التي سجل عليها :wow:  ليتكم

تبدلونها بما شاء الله لا قوة إلا بالله 

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

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

الأخ الكريم بدء الكلام بالسلام أفضل .. السلام عليكم

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

http://www.officena.net/ib/index.php?showtopic=60147

حتى  تهتدى لإجابة و حل لمسئلتك دون الخوض فى الكثير من النقاش.. عليك برفع ملف للتطبيق عليه حتى يأتى متماشيا مع طبيعة ملفك الأصلى.. أى ليس شرطا ان يحتوى على بيانات حقيقية و لكن على الأقل صورة مشابة للأصلى من حيث الأعمدة و الصفوف و رؤوس الأعمدة و ترتيبها ( بين الدفتر الأساسى و شيتات المحافظات ).. بدأت بساجة و انتهيت بمسخ ( اعرف انها سادة و نسخ .. و لكن الحمد لله اننى لست فى مزاج رائق للقفشة حتى أقتنصها .. بل اشرت اليها فقط ).. دمت بخير و أعزك الله

أخي الحبيب علاء رسلان المحترم أعلى الله شأنك في الدارين...رويدك قليلاً فأنت لا تعرف ظرفه ..دقة نظره ..مهارته في الكتابة...اجعل لأخيك سبعين عذراً 

واعذرني أيضاً فما من نصيحة إلا من أخ محب ...فلكل منا من اسمه نصيب (فعلى رسلك) ... 

ولكم في رسول الله أسوة حسنة ... فما كان الحلم في شيءٍ إلا زانه...أقول لك من تجربة.... فأنا نظري على قد حاله ولا أرى إلا بعين واحدة منذ لحظة الولادة...وأخيرأ تقبل تحيات أخ محبٍّ

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

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

أخي الفاضل عبد الله شيخون

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

 

كان يجب أن تنوه أن هناك ورقة عمل مخفية للتعامل معها .. عموماً قد تداركت الأمر وقمت بعمل اللازم

إليك الملف المرفق بعد إضافة كود يمسح البيانات من جميع أوراق العمل ما عدا ورقة العمل "الدفتر" وورقة العمل المخفية "كود"

Sub ClearAllExceptMain()
    Dim SH As Worksheet
    For Each SH In ThisWorkbook.Worksheets
        If SH.Name <> "الدفتر" And SH.Name <> "كود" Then SH.Range("B3:L1000").ClearContents
    Next SH
End Sub

إن شاء الله يفي بالغرض

 

الأخ الكريم ابو يوسف المصري

أحبك الله الذي أحببتني فيه .. بارك الله فيك وجزاك الله خير الجزاء وجمعنا الله في الجنة في مستقر رحمته

 

الأخ الحبيب الغالي ابو يوسف

بارك الله فيك وجزيت خيراً على تشجيعك الدائم لابنك .. تقبل الله منا ومنكم

Transfer Data By Region YasserKhalil.rar

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

الأخ الحبيب محمد حسن المحمد من وطنى سوريا الذى هو جزء من وطنى الأكبر من وطنك مصر

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

دمت بخير و أعزك الله

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

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

تقبل الله صيامنا

اولا مشكوراٌ على كود المسح . ولكن بعد اضافة الكود لا يتم ترحيل الا بيانات الجيزة وطنطا اما باقى المحافظات لا عند الضغط على زر الترحيل تظهر رسالة Rangeمن الفئة select فشل اسلوب. ارجوا ان يتم ترحيل جميع المحافظات كل شيت بما يخصه. وشكرا لكم

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

  • أفضل إجابة

جرب الأكواد بهذا الشكل (رغم أن الملف يعمل عندي على أوفيس 2013 بدون مشاكل)

Sub TarhilByRegion()
    Dim WS As Worksheet
    Dim Cell As Range
    Dim strSheet As String
    Dim LR As Long
    
    Set WS = Sheets("الدفتر")
    Application.ScreenUpdating = False
        For Each Cell In WS.Range("J3:J" & WS.Cells(Rows.Count, "J").End(xlUp).Row)
            strSheet = Cell.Value
            On Error GoTo 1
            LR = IIf(Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row < 3, 3, Sheets(strSheet).Cells(Rows.Count, "D").End(xlUp).Row + 1)
            Cell.Offset(, -8).Copy
            Sheets(strSheet).Range("D" & LR).PasteSpecial xlPasteValues
            Cell.Offset(, -6).Resize(, 8).Copy
            Sheets(strSheet).Range("E" & LR).PasteSpecial xlPasteValues
1       Next Cell
    WS.Activate
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Sub ClearAllExceptMain()
    Dim SH As Worksheet
    For Each SH In ThisWorkbook.Worksheets
        If SH.Name <> "الدفتر" And SH.Name <> "كود" Then SH.Range("B3:L1000").ClearContents
    Next SH
End Sub

لا تنسى أخي الفاضل أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

ولا تنسى أن تضغط على "أعجبني هذا" .. لاحظت أن الإعجابات ليست من صاحب الموضوع نفسه إنما من أعضاء وأخوة آخرين بمجرد إطلاعهم على الموضوع فعجباً

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

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