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

[عبدالله شيخون]

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

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

[علاء رسلان]

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

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

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

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

[عبدالله شيخون]

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

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

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

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

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

تقبل تحياتي

 

Transfer Data By Region YasserKhalil.rar

[عبدالله شيخون]

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

رمضان كريم

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

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

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

[ابو يوسف المصري]

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

[محمد حسن المحمد]

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

 

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

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

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

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

[محمد حسن المحمد]

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

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

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

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

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

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

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

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

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

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

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

 

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

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

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

[علاء رسلان]

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

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

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

[عبدالله شيخون]

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

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

اولا مشكوراٌ على كود المسح . ولكن بعد اضافة الكود لا يتم ترحيل الا بيانات الجيزة وطنطا اما باقى المحافظات لا عند الضغط على زر الترحيل تظهر رسالة 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

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

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

[عبدالله شيخون]

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

ورمضان كريم

الكود بدء يعمل بشكل جيد فى الترحيل والمسح

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

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

تقبل الله منا ومنكم