دمج أوراق العمل من مصنفات مختلفة إلى مصنف واحد (المجمع)

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

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

إخواني الأحباب ...

 

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

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

 

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

المهم .. اليوم معانا الكود الذي يقوم بذلك ، يقوم الكود بالدخول إلى مسار تم تحديده مسبقاً ، وفي داخل المسار (أنا وضعت المصنفات داخل مجلد باسم Test) ، فيقوم الكود بفتح كل مصنف من المصنفات الموجودة ، ثم يدور في حلقة تكرارية لأوراق العمل داخل المصنف الواحد ، ثم ينسخها ، ويضعها بالمصنف الذي يحوي الكود ..)

الكود مشروح كالسابق .. سطر بسطر :

Sub CollectWorkbooks()
    'تعريف المتغير من النوع نصي
    Dim Path As String
    'تعريف المتغير من النوع نصي
    Dim Filename As String
    'تعريف المتغير من النوع ورقة عمل
    Dim SH As Worksheet
    'تعريف المتغير للترتيب الصحيح لأوراق العمل
    Dim X As Long
    'تعيين القيمة 1 للمتغير كبداية
    X = 1
    'تعيين المتغير ليساوي مسار المجلد الذي يحوي المصنفات المراد دمج أوراق العمل منها
    Path = ThisWorkbook.Path & "\Test\"
    'تعيين المتغير ليساوي اسم كل مصنف من المصنفات التي سيتم التعامل معها
    Filename = Dir(Path & "*.xlsm")
    'إلغاء خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
    'إلغاء خاصية التنبيه بالرسائل
    Application.DisplayAlerts = False
        'حلقة تكرارية للمصنفات الموجودة في المسار المحدد إلى أن لا يجد أي مصنف بالمسار
        Do While Filename <> ""
            'فتح المصنف
            Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
                'حلقة تكرارية لكل أوراق العمل داخل المصنف النشط
                For Each SH In ActiveWorkbook.Sheets
                    'نسخ ورقة العمل ولصقها بنهاية فهرس أوراق العمل
                    SH.Copy After:=ThisWorkbook.Sheets(X)
                    'زيادة قيمة المتغير بمقدار 1
                    X = X + 1
                'الانتقال لورقة العمل التالية
                Next SH
            'إغلاق المصنف
            Workbooks(Filename).Close
            'إعادة ضبط المتغير
            Filename = Dir()
        Loop
    'تنشيط أو تحديد ورقة العمل الأولى
    Sheets("Collector").Activate
    'تفعيل خاصية التنبيه بالرسائل
    Application.DisplayAlerts = True
    'تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

بعد فك الضغط عن الملف المرفق ، ستجدون المصنف المسمى Collect Workbooks ...ومجلد باسم Test يحوي المصنفات التي سيتم دمجها ..

قم بفتح المصنف Collect Workbooks ثم انقر زر الأمر RUN ليقوم الكود بعملية الدمج لكل أوراق العمل بكل المصنفات الموجودة داخل المجلد Test

دمتم في رعاية الله وطاعته

حمل الملف من هنا

كان معكم أخوكم أبو البراء من منتدى أوفيسنا

[ابو القبطان]

استاذ : ياسر 

الاول نشكرك على التواجد الفعال لحضرتك بالمنتدى ، ولس فعال فقط دا انت بتجيب درر و روائع ، ذكرتنا بالاستاذ الغائب الحاضر : حماده عمر

نسيبك مع عفاريتك ... ونحمل ملفك ونعيش مع ابداعاتك

[Yasser Fathi Albanna]

أنت بالفعل علامه أخى الغالى ياسر

ومبروك على قناتك الجديدة

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

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

ايه  ده كله   ده كله  ده كله

 

وكمان بتطلع عفاريت  !!!

 

مدد ياعم الشيخ مـــــــــــــــــــدد

 

والأدهى فتحت قناة على اليوت    

 

 

عقبال  YASSERSAT التليفزيونية

 

وبركاتك يا سيدنا الشيخ بركاااتك

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

الأخ الحبيب جدو الغالي المربع في قلوبنا أبو القبطان

مشكور على مرورك العطر بالموضوع ..

عايز أقولك : بيقولوا على السواقين عفاريت الأسفلت ، إحنا بقا عفاريت الإكسيل (هنعصر الإكسيل نطلع منه عفاريت صغيرين)

 

الأخ الغالي ياسر البنا

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

 

الأخ الحبيب مختار ..

حلوة YASSERSAT دي .. جديدة وأنا بحب الجديد دايما ..عموما ممكن نفكر في الموضوع ، بس همتك معايا ، عايزين يكون قمر صناعي ولا القمر في ليلة التمام ..فاهمني يا همام

مشكور إخواني على مروركم العطر ..بارك الله فيكم

[ابو القبطان]

استاذ : ياسر 

ملف جميل وفكره رائعه

بس .. لما استخدمنا الملفات  المتفرقه واغلقناها ، وطلبنا الدمج .. تم وكله تمام 

لكن لما اعدنا استخدام الملفات المتفرقة مره اخرى واضفنا بانات جديده للشتات وطلبنا الدمج مرة ثانية 

تكرر الشيت الاول في ملف الدمج مرتين باسمين ولكن رئيسي و رئيسي 1 ، وهكذا .. بمعنى اضافة البيانات مرة ثانيه لنفس الشيت تم دمجها باسم تاني 

اعتقد انه توجد وسيله تلغي الشيتات القديمه ويستقبل ملف الدمج البيانات الحديثه .. 

مجرد ملاحظه ( خلي العفريت يكمل جميله ويحلها )

ماشاء الله يا مبدع

تسلم ايدك

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

أخي أبو القبطان

إحنا ما صدقنا العفريت نام .. عموما .ضع الأسطر التالية بعد السطر الخاص بإلغاء خاصية التنبيه بالرسائل

        '[Collector]حلقة تكرارية لحذف أوراق العمل ما عدا الورقة المسماة
        For Each SH In ThisWorkbook.Sheets
            If SH.Name <> "Collector" Then SH.Delete
        Next SH

الأسطر دي سيتم تنفيذها قبل باقي الأسطر بحيث تحذف كل أوراق العمل ما عدا الورقة المسماة Collector .. تجنياً لتكرار أوراق العمل

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

 الله ينور تم اضافة السطور وتم تحديث الملف   Collect Workbooks  بالملفات محدثةً     مخاوى أكيد مخاوى

[محي الدين ابو البشر]

ما شاء الله

بارك الله بك استاذ ياسر

[ابو القبطان]

تمت الاضافة استاذ ياسر ، واصبح ولا اروع

[أبو إيمان]

جزاكم الله خيرا أستاذنا ياسر

[إبراهيم ابوليله]

اخى ياسر

برنس والله

اعمال يفتخر بها الجميع

تقبل تحياتى

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

مشكور إخواني الكرام على مروركم العطر

تحية خاصة لحبيبي في الله إبراهيم أبو ليلة صاحب الإبداعات المميزة في المنتدى خصوصا في مجال الفواتير (اللي تقريبا نص الأعضاء بيسألوا على التعامل معها .. )

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

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

[محسن أبومحمد]

بسم الله ما شاء الله

جزاك الله خير استاذنا ياسر أبو الخليل

طلب بسيط  من عمالقة المنتدى

ما التغيير في الكود اذا كنت احتاج إلى نسخ شيت معين وليس جميع الشيتات

مع خالص الشكر والتقدير

[أحمد يوسف]

ارفع ملف مع الشرح بالتفصيل لما تريد

[محسن أبومحمد]

استاذنا الفاضل / أحمد يوسف

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

 Do While Filename <> ""
            'فتح المصنف
            Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
                'حلقة تكرارية لكل أوراق العمل داخل المصنف النشط
                For Each SH In ActiveWorkbook.Sheets
                    'نسخ ورقة العمل ولصقها بنهاية فهرس أوراق العمل
                    SH.Copy After:=ThisWorkbook.Sheets(X)
                    'زيادة قيمة المتغير بمقدار 1
                    X = X + 1
                'الانتقال لورقة العمل التالية
                Next SH
            'إغلاق المصنف
            Workbooks(Filename).Close

 

ما احتاج اليه هو نسخ sheet1  فقط وليس جميع الأوراق

 

وجزاكم الله خير على علمكم وصبركم وعطاؤكم