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

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


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

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

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

 

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

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

 

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

المهم .. اليوم معانا الكود الذي يقوم بذلك ، يقوم الكود بالدخول إلى مسار تم تحديده مسبقاً ، وفي داخل المسار (أنا وضعت المصنفات داخل مجلد باسم 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

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

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

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

:fff: :fff: :fff:

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

استاذ : ياسر 

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

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

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

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

 

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

 

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

 

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

 

 

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

 

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

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

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

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

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

 

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

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

 

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

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

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

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

استاذ : ياسر 

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

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

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

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

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

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

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

تسلم ايدك

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

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

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

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

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

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

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

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

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

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

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

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

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

  • 4 years later...

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

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

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

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

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

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

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

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

 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  فقط وليس جميع الأوراق

 

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

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

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