ياسر خليل أبو البراء قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 السلام عليكم ورحمة الله وبركاته إخواني الأحباب ... سبق أن تناولت في موضوع سابق (الانشطار الكبير .. انشطار أوراق العمل بالمنصف إلى مصنفات مختلفة) في هذا الرابط 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 دمتم في رعاية الله وطاعته حمل الملف من هنا كان معكم أخوكم أبو البراء من منتدى أوفيسنا
ابو القبطان قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 استاذ : ياسر الاول نشكرك على التواجد الفعال لحضرتك بالمنتدى ، ولس فعال فقط دا انت بتجيب درر و روائع ، ذكرتنا بالاستاذ الغائب الحاضر : حماده عمر نسيبك مع عفاريتك ... ونحمل ملفك ونعيش مع ابداعاتك 2
Yasser Fathi Albanna قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 أنت بالفعل علامه أخى الغالى ياسر ومبروك على قناتك الجديدة جزاك الله خيرا 1
مختار حسين محمود قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 ايه ده كله ده كله ده كله وكمان بتطلع عفاريت !!! مدد ياعم الشيخ مـــــــــــــــــــدد والأدهى فتحت قناة على اليوت عقبال YASSERSAT التليفزيونية وبركاتك يا سيدنا الشيخ بركاااتك 1
ياسر خليل أبو البراء قام بنشر مارس 15, 2015 الكاتب قام بنشر مارس 15, 2015 الأخ الحبيب جدو الغالي المربع في قلوبنا أبو القبطان مشكور على مرورك العطر بالموضوع .. عايز أقولك : بيقولوا على السواقين عفاريت الأسفلت ، إحنا بقا عفاريت الإكسيل (هنعصر الإكسيل نطلع منه عفاريت صغيرين) الأخ الغالي ياسر البنا الله يبارك فيك ، وبعدين لا علامة ولا حتى حصلت أستاذ أنا يدوب مجتهد بحاول أجيب كل ما هو جديد ومفيد الأخ الحبيب مختار .. حلوة YASSERSAT دي .. جديدة وأنا بحب الجديد دايما ..عموما ممكن نفكر في الموضوع ، بس همتك معايا ، عايزين يكون قمر صناعي ولا القمر في ليلة التمام ..فاهمني يا همام مشكور إخواني على مروركم العطر ..بارك الله فيكم
ابو القبطان قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 استاذ : ياسر ملف جميل وفكره رائعه بس .. لما استخدمنا الملفات المتفرقه واغلقناها ، وطلبنا الدمج .. تم وكله تمام لكن لما اعدنا استخدام الملفات المتفرقة مره اخرى واضفنا بانات جديده للشتات وطلبنا الدمج مرة ثانية تكرر الشيت الاول في ملف الدمج مرتين باسمين ولكن رئيسي و رئيسي 1 ، وهكذا .. بمعنى اضافة البيانات مرة ثانيه لنفس الشيت تم دمجها باسم تاني اعتقد انه توجد وسيله تلغي الشيتات القديمه ويستقبل ملف الدمج البيانات الحديثه .. مجرد ملاحظه ( خلي العفريت يكمل جميله ويحلها ) ماشاء الله يا مبدع تسلم ايدك 1
ياسر خليل أبو البراء قام بنشر مارس 15, 2015 الكاتب قام بنشر مارس 15, 2015 أخي أبو القبطان إحنا ما صدقنا العفريت نام .. عموما .ضع الأسطر التالية بعد السطر الخاص بإلغاء خاصية التنبيه بالرسائل '[Collector]حلقة تكرارية لحذف أوراق العمل ما عدا الورقة المسماة For Each SH In ThisWorkbook.Sheets If SH.Name <> "Collector" Then SH.Delete Next SH الأسطر دي سيتم تنفيذها قبل باقي الأسطر بحيث تحذف كل أوراق العمل ما عدا الورقة المسماة Collector .. تجنياً لتكرار أوراق العمل
مختار حسين محمود قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 الله ينور تم اضافة السطور وتم تحديث الملف Collect Workbooks بالملفات محدثةً مخاوى أكيد مخاوى 1
محي الدين ابو البشر قام بنشر مارس 15, 2015 قام بنشر مارس 15, 2015 ما شاء الله بارك الله بك استاذ ياسر 1
إبراهيم ابوليله قام بنشر مارس 16, 2015 قام بنشر مارس 16, 2015 اخى ياسر برنس والله اعمال يفتخر بها الجميع تقبل تحياتى 1
ياسر خليل أبو البراء قام بنشر مارس 16, 2015 الكاتب قام بنشر مارس 16, 2015 مشكور إخواني الكرام على مروركم العطر تحية خاصة لحبيبي في الله إبراهيم أبو ليلة صاحب الإبداعات المميزة في المنتدى خصوصا في مجال الفواتير (اللي تقريبا نص الأعضاء بيسألوا على التعامل معها .. ) بارك الله فيكم جميعا وجزاكم الله خير الجزاء تقبلوا تحياتي
محسن أبومحمد قام بنشر يوليو 13, 2019 قام بنشر يوليو 13, 2019 بسم الله ما شاء الله جزاك الله خير استاذنا ياسر أبو الخليل طلب بسيط من عمالقة المنتدى ما التغيير في الكود اذا كنت احتاج إلى نسخ شيت معين وليس جميع الشيتات مع خالص الشكر والتقدير
محسن أبومحمد قام بنشر يوليو 14, 2019 قام بنشر يوليو 14, 2019 استاذنا الفاضل / أحمد يوسف التالي هو جزء من الكود الأصلي حسب شرح استاذنا ياسر أبو الخليل ويتضمن نسخ جميع أوراق العمل من داخل الملف 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.