صناعة ملفات اكسل من ملف اكسل ماستر

[أبو محمد المنار]

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

 

الأخوة الاعزاء

 

لدي ملف اكسل اسمه (Master_file) فيه معلومات الموظفين كيف أصنع ملف أكسل لكل موظف و هذا الملف يأخذ معلوماته من الملف  (Master_file)  اتومايتكيا يعني هو يسوي صناعة للملفات.

مثال مرفق

 

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

 

Master_file.zip

[أبو محمد المنار]

من لها؟

[طارق محمود]

سهلة إن شاء الله
إن لم يتدخل أحد حتي نهاية الدوام عندي سأبدأ فيها

[أبو إيمان]

ياليت نعمل كدا ونعمل العكس أي ملف يجمع بياناته من ملفات مختلفه

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

الأخ الحبيب والمعلم الكبير طارق

اسمح لي أن أتقدم رغم أنه لا يحق لي التدخل بعد ردك ..إلا أنني كنت قد جهزت الكود ولكن عطلني أنني أردت شرحه للاستفادة منه

الأخ الكريم المنار (ربنا يكفيك شر النار وشر الأشرار ويجعلك من المتقين الأبرار) :fff:

إليك الملف التالي وإن شاء الله يفي بالغرض

Sub SplitWB()
'يقوم الكود بفصل بيانات كل موظف في مصنف جديد مقسم إلى أوراق عمل جديدة
'--------------------------------------------------------------------
'تعريف المتغيرات
    Dim WB As Workbook
    Dim Arr
    Dim I As Long
'إلغاء خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
'تعيين قيمة للمتغير ليساوي كل القيم في النطاق الحالي في ورقة العمل
'المتغير يخزن البيانات على شكل مصفوفة
        Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value
'حلقة تكرارية من الصف الثاني وحتى آخر صف به بيانات
'الحد الأعلى للبعد الأول للمصفوفة ألا وهو بعد الصفوف [UBound(Arr, 1)] حيث يمثل هذا الجزء
        For I = 2 To UBound(Arr, 1)
'ليساوي المصنف الجديد [WB] تعيين المتغير
           Set WB = Workbooks.Add
'بدء التعامل مع المصنف الجديد
           With WB
'إضافة ورقة عمل باسم "ملاحظات" ، ووضع البيانات المرتبطة من العمود التاسع بالمصفوفة
               With .Sheets.Add
                   .Name = "ملاحظات"
                   .Range("A1") = "ملاحظات"
                   .Range("B1") = Arr(I, 9)
                   .Columns.AutoFit
               End With
'إضافة ورقة عمل باسم "الأداء والمعلومات المالية" ، ووضع البيانات المرتبطة من العمود الرابع والسابع والثامن بالمصفوفة
               With .Sheets.Add
                   .Name = "الأداء والمعلومات المالية"
                   .Range("A1").Resize(3, 1) = Application.Transpose(Array("التقييم السنوي", "الراتب", "البدلات"))
                   .Range("B1") = Arr(I, 4)
                   .Range("B2") = Arr(I, 7)
                   .Range("B3") = Arr(I, 8)
                   .Columns.AutoFit
               End With
'إضافة ورقة عمل باسم "المعلومات الأساسية" ، ووضع البيانات المرتبطة من العمود الأول والثاني والثالث والخامس بالمصفوفة
               With .Sheets.Add
                   .Name = "المعلومات الأساسية"
                   .Range("A1").Resize(5, 1) = Application.Transpose(Array("اسم الموظف", "تاريخ التعيين", "الجنسية", "الوحدة", "الشعبة"))
                   .Range("B1") = Arr(I, 1)
                   .Range("B2") = Arr(I, 2)
                   .Range("B3") = Arr(I, 3)
                   .Range("B4") = Arr(I, 5)
                   .Range("B5") = Arr(I, 6)
                   .Columns.AutoFit
               End With
'وهي ورقة عمل افتراضية في أي مصنف جديد [Sheet1] حذف ورقة العمل المسماة
               .Sheets("Sheet1").Delete
'حفظ المصنف الجديد في نفس مسار المصنف الحالي باسم البيان الموجود في العمود الأول بالمصفوفة
               .SaveAs ThisWorkbook.Path & "\" & Arr(I, 1) & ".xlsx"
'إغلاق المصنف الجديد الذي تم حفظه
               .Close
           End With
'الانتقال لصف جديد والتعامل مع مصنف جديد
    Next I
'إعادة تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
'رسالة تفيد بانتهاء عمل الكود
    MsgBox "Done !", vbInformation
End Sub

وفي انتظار مساهمتك يا باشمهندس .. زيادة الخير خيرين ..

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

Split Data Into Mulptiple Workbooks YasserKhalil.rar

[طارق محمود]

بالعكس أيها الحبيب ياسر 

لقد أزحت عني حملا كنت حملت نفسي به ولاأجد الوقت

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

[أبو محمد المنار]

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

 

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

 

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

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

حبيبي في الله ومعلمي باشمهندس طارق

يكفينا منك مرورك العطر وأعانك الله ووسع دارك وبارك الله في رزقك وأهلك ومالك

 

أخي الكريم المنار

الحمد لله أن تم المطلوب على خير

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

[أبو محمد المنار]

الحل رائع و ممتاز كنت أسأل ان كان لي تنسيق معين (فورمات  جاهزة) ويتم ترحيل بيانات الملف الماسترلها.

 

و استفسار في حالة كان لديك حوالي 70 متغيرلازم تربط كل واحدة بكود

تم تعديل مايو 28, 2015 بواسطه المنار

[أبو محمد المنار]

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

ممكن تجيب على تساؤلي 

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

أخي الفاضل

حضرتك طرحت ملف مرفق وشكل للنتائج المتوقعة وتم العمل على هذا الأساس ..

أعتقد إذا كان الطلب سيتمحور حول نقاط أخرى أفضل أن تطرح موضوع جديد ..

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

 

بالنسبة لسؤالك لو كان فيه تنسيق معين (فورمات جاهزة) هل تقصد أن هناك مصنف جاهز لعملية الإدخال أم أن هناك مصنفات بالفعل لكل موظف ؟ ولما لم تنوه عن ذلك في الموضوع من البداية

ماذا تقصد بـ 70 متغير ؟هل تقصد 70 بيان في 70 عمود أم ماذا؟

[أبو محمد المنار]

صدقت أخي ياسر

ظننت الموضوع بسيط وسيكون بدون برمجة لذا وضعت مثالا بسيطا<<<< 

 

شكر للنصيحة بعد قليل ارسل موضوعا اخر 

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

السلام عليكم إخوتي الكرام ...أخي الحبيب ياسر أبو البراء

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

لقد نزلت الملف المذكور بعدأن اختيرت أفضل إجابة وجربته إلا أنه أعطاني :

Run-time error '9' Subscript out of range  فما السبب برأيكم؟. علماً أنني فككت الضغط عن الملف .

ملاحظة: تم إعطاء الاسم الأول فقط .

أكرر اعتذاري لأخوتي الذين أرجو الله لهم خيري الدنيا والآخرة.

أخوكم أبو يوسف.

تم تعديل مايو 29, 2015 بواسطه محمد حسن المحمد

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

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

ما السطر الذي يحدث عنده خطأ ؟ وما هي نسخة الأوفيس التي تعمل عليها ؟

 

الأخ الكريم المنار

أحسنت في فكرة تقديم موضوع جديد ..

هل كنت فعلاً أنه يمكن معالجة الأمر بدون برمجة !! المعادلات عملها محدود للغاية ، بينما البرمجة تفتح لك آفاقاً واسعة

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

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

السلام عليكم أخي أبو البراء الغالي

أرفع لكم صورة عن الخطأ الذي أخبرتكم عنه....أوفيس 2007

تقبلوا تحياتي...السلام عليكم.

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

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

ما السطر الذي يحدث عنده خطأ ؟ وما هي نسخة الأوفيس التي تعمل عليها ؟

 

الأخ الكريم المنار

أحسنت في فكرة تقديم موضوع جديد ..

هل كنت فعلاً أنه يمكن معالجة الأمر بدون برمجة !! المعادلات عملها محدود للغاية ، بينما البرمجة تفتح لك آفاقاً واسعة

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

يا من فهّم سليمان فهمنا ...ويا من علم داود علمنا ...اللهم علمنا ما ينفعنا وانفعنا بماعلمتنا ...آمين

العلم من الصغر كالنقش في الحجر والعلم في الكبر كوخز الأبر.....يمكن راحت علينا...ختيرنا...

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

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

جرب التعديل البسيط في الكود

Sub SplitWB()
'يقوم الكود بفصل بيانات كل موظف في مصنف جديد مقسم إلى أوراق عمل جديدة
'--------------------------------------------------------------------
'تعريف المتغيرات
    Dim WB As Workbook
    Dim Arr
    Dim I As Long
'إلغاء خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
'تعيين قيمة للمتغير ليساوي كل القيم في النطاق الحالي في ورقة العمل
'المتغير يخزن البيانات على شكل مصفوفة
        Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value
'حلقة تكرارية من الصف الثاني وحتى آخر صف به بيانات
'الحد الأعلى للبعد الأول للمصفوفة ألا وهو بعد الصفوف [UBound(Arr, 1)] حيث يمثل هذا الجزء
        For I = 2 To UBound(Arr, 1)
'ليساوي المصنف الجديد [WB] تعيين المتغير
           Set WB = Workbooks.Add
'بدء التعامل مع المصنف الجديد
           With WB
'إضافة ورقة عمل باسم "ملاحظات" ، ووضع البيانات المرتبطة من العمود التاسع بالمصفوفة
               With .Sheets.Add
                   .Name = "ملاحظات"
                   .Range("A1") = "ملاحظات"
                   .Range("B1") = Arr(I, 9)
                   .Columns.AutoFit
               End With
'إضافة ورقة عمل باسم "الأداء والمعلومات المالية" ، ووضع البيانات المرتبطة من العمود الرابع والسابع والثامن بالمصفوفة
               With .Sheets.Add
                   .Name = "الأداء والمعلومات المالية"
                   .Range("A1").Resize(3, 1) = Application.Transpose(Array("التقييم السنوي", "الراتب", "البدلات"))
                   .Range("B1") = Arr(I, 4)
                   .Range("B2") = Arr(I, 7)
                   .Range("B3") = Arr(I, 8)
                   .Columns.AutoFit
               End With
'إضافة ورقة عمل باسم "المعلومات الأساسية" ، ووضع البيانات المرتبطة من العمود الأول والثاني والثالث والخامس بالمصفوفة
               With .Sheets.Add
                   .Name = "المعلومات الأساسية"
                   .Range("A1").Resize(5, 1) = Application.Transpose(Array("اسم الموظف", "تاريخ التعيين", "الجنسية", "الوحدة", "الشعبة"))
                   .Range("B1") = Arr(I, 1)
                   .Range("B2") = Arr(I, 2)
                   .Range("B3") = Arr(I, 3)
                   .Range("B4") = Arr(I, 5)
                   .Range("B5") = Arr(I, 6)
                   .Columns.AutoFit
               End With
'وهي ورقة عمل افتراضية في أي مصنف جديد [Sheet1] حذف ورقة العمل المسماة
               .Sheets("Sheet1").Delete
'حفظ المصنف الجديد في نفس مسار المصنف الحالي باسم البيان الموجود في العمود الأول بالمصفوفة
               .SaveAs ThisWorkbook.Path & "\" & Arr(I, 1) & ".xlsx"
'إغلاق المصنف الجديد الذي تم حفظه
               .Close
           End With
'الانتقال لصف جديد والتعامل مع مصنف جديد
    Next I
    Application.DisplayAlerts = True
'إعادة تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
'رسالة تفيد بانتهاء عمل الكود
    MsgBox "Done !", vbInformation
End Sub

تم إضافة سطرين لإلغاء رسائل التنبيه وإعداة تفعيلها بعد انتهاء الكود

الغريب أن الكود يعمل معي بدون رسالة الخطأ وعلى نفس النسخة 2007

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

السلام عليكم أخي أبو البراء الغالي:

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

نظرت إلى أمر لم يكن بالحسبان لدي .Sheets("Sheet1").Delete حيث أن أسماء الأوراق لدي بالعربية

أصبحت كما يلي:  ("ورقة 1") بدلاً من ("sheet1").. وقد نجحت المحاولة نجاحاً باهراً....

تهانينا لكم على هذا العمل الررائع

والسلام عليكم.

تم تعديل مايو 29, 2015 بواسطه محمد حسن المحمد