مطلوب شيت تجميع ( تجميع بيانات من عدة ملفات باي عدد لملف واحد بضغطة زر ) { عنوان معدل }

[ابو يوسـف]

السادة الكرام

خالص تقديري واحترامي لمجهودكم في نشر العلم

 

برجاء من سيادتكم الإفادة حيال شيت تجميع البيانات من شيتات متعددة

 

مرفق مجلد لتوضيح المطلوب

 

تفضلوا بقبول خالص التقدير

 

 

تجميع شيتات.rar

تم تعديل مارس 20, 2014 بواسطه baselnagar

[حمادة عمر]

السلام عليكم

الاخ الكريم /   baselnagar

بارك الله فيك

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

في كشف واحد اسفل بعض في ملف تجميع

وان كان كذلك ... شاهد المرفق التالي ( ولكن تم التنفيذ علي مدرستين فقط كمثال (( الحرية 1 - الحرية 2 ))

 

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

قم بفتح ملف ( تجميع ) ثم اضغط علي زر ( تجميع البيانات ) وشاهد النتيجة

 

** ملحوظة : يجب ان يكون ملف تجميع في نفس الفولدر مع المدارس كما هو مرفق بالمرفقات

تقبل خالص تحياتي

 

 

شاهد المرفق

 

المدارس.rar

[حمادة عمر]

وبرجاء الاطلاع علي الرابط التالي

لتغيير الاسم الي العربية ( طبقا لسياسة وشروط المنتدي ) ولزيادة التواصل .... برجاء الاطلاع علي الموضوع

http://www.officena....showtopic=41520

[ابو يوسـف]

اشكرك مشرفنا العزيز .. تم تعريب الاسم ..

 

إذا سمح وقتكم الثمين إذ امكن شرح أو مناقشة الكود .. تعديل الكود ليستخدم مع 110 مدرسة

تم تعديل مارس 21, 2014 بواسطه ابو يوسـف

[ابو يوسـف]

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

فماذا عن تحديد الشيت ( اعمال السنة ) حتى ولو لم يكن هو النشط

[حمادة عمر]

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

فماذا عن تحديد الشيت ( اعمال السنة ) حتى ولو لم يكن هو النشط

 

بالنسبة لتحديد شيت اعمال السنة اخي الكريم

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

Range("A11:Y1000").Copy

بهذا السطر .... لتحديد شيت ( اعمال سنة )

 Sheets("اعمال سنة").Range("A11:Y1000").Copy

وعذرا ع التأخر في الرد ... نظرا لانشغالي في العمل

تقبل خالص تحياتي

[رائد 1982]

كود في منتهي الجمال

استاذنا القدير / حمادة عمر

دمت لنا

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

[حمادة عمر]

كود في منتهي الجمال

استاذنا القدير / حمادة عمر

دمت لنا

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

 

مرور طيب وكريم من اخ كريم

تقبل خالص تحياتي اخي الكريم / رائد

[حمادة عمر]

اشكرك مشرفنا العزيز .. تم تعريب الاسم ..

 

إذا سمح وقتكم الثمين إذ امكن شرح أو مناقشة الكود .. تعديل الكود ليستخدم مع 110 مدرسة

 

السلام عليكم

الاخ الكريم / ابو يوسـف

بارك الله فيك

اسمك منور بالعربي ياراجل ... ايوه كده

 

بالنسبة لهذا الطلب فعذرا لم اراه الا الآن

اليك الكود التالي ... ولكن هناك بعض الملاحظات لطريقه عمله

1- قم بوضع اسماء ملفات المدارس الموجودة لديك والتي تريد تجميع بياناتها في ملف تجميع في العمود AA  اسفل بعض

    والكود يعمل علي 110 ملف .... وان اردت زيادتهم ما عليك الا زيادة الرقم 110 في الكود  الي الرقم الذي تريده

 

2- شاهد الملف وطريقه عمله واي شرح لاي جزء من الكود ... اخبرني ومعك دائما باذن الله

3- كما سبق ذكره يجب ان يكون ملف تجميع موجود في نفس فولدر المدارس

4- تم وضع مثال  لعدد 5 مدارس من ملفاتك المرفقة

Private Sub CommandButton1_Click()
Dim I As Integer
Dim File As String
Dim LR As Long
Set ws = Worksheets("ورقة1")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
'-----------------------------
ws.Range("A11:Y10000").ClearContents
For I = 1 To 110
If Cells(I, 27) = "" Then Exit For
TextBox1.Value = Cells(I, 27).Value
File = ActiveWorkbook.Path & "\" & TextBox1.Value
Workbooks.Open File
Sheets("اعمال سنة").Range("A11:Y1000").Copy
'-----------------------------
Windows("تجميع.xls").Activate
ws.Select
LR = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ws.Cells(LR, 1).Select
ws.Paste
Range("a11").Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
Next I
Unload Me
End Sub

ارجو ان يفي بطلبك  ...  جرب واشعرنا بالنتائج

واهلا وسهلا بك بيننا وسط اخوه لك في الله ( بالعربي ) ... هههه

تقبل خالص تحياتي

 

 

تجميع بيانات المدارس.rar

[حسام مصطفي]

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

استاذي القدير / حمادة عمر

كود راائع

ولي عودة بطلب آخر بعد اذنكم

[حمادة عمر]

السلام عليكم

الاخ الفاضل / حسام مصطفي

بارك الله فيك

وجعلني دائما عند حسن ظنك

ومعك دائما باذن الله في اي استفسار او طلب في حدود علمي

تقبل خالص تحياتي

[ابو يوسـف]

جزاك الله خيرا استاذنا الفاضل

كفيت ووفيت

[حمادة عمر]

بارك الله فيك

اخي الكريم

تقبل خالص تحياتي

[حسام مصطفي]

استاذي القدير العزيز / حمادة عمر

لدي بعض الملفات مثل ذلك العمل ولذلك اخبرتك بان لي عودة

 

الكود يعمل بصورة جيدة جدا بل ممتازة ولكن يقوم الكود بفتح كل الملفات الموجود بها البيانات المطلوبة

هل من الممكن اغلاق هذه الملفات كلها مرة اخري وجعل الملف الرئيسي الذي تم احضار البيانات اليه مفتوحا

 

تلميذك

[حمادة عمر]

السلام عليكم

الاخ الفاضل / حسام مصطفي

بارك الله فيك

 

لتنفيذ طلبك اخي الكريم ...

استبدل الكود السابق بالكود التالي ....

Private Sub CommandButton1_Click()
Dim I As Integer
Dim File As String
Dim LR As Long
Dim all_ws As Workbook
'-----------------------------
Set ws = Worksheets("æÑÞÉ1")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
'-----------------------------
ws.Range("A11:Y10000").ClearContents
For I = 1 To 110
If Cells(I, 27) = "" Then Exit For
TextBox1.Value = Cells(I, 27).Value
File = ActiveWorkbook.Path & "\" & TextBox1.Value
Workbooks.Open File
Sheets("ÇÚãÇá ÓäÉ").Range("A11:Y1000").Copy
'-----------------------------
Windows("ÊÌãíÚ.xls").Activate
ws.Select
LR = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ws.Cells(LR, 1).Select
ws.Paste
Range("a11").Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
Next I

For Each all_ws In Application.Workbooks
If Not all_ws.Name = ThisWorkbook.Name Then all_ws.Close (True)
Next all_ws

Unload Me
End Sub

ومعك دائما في اي استفسار تريده

تقبل خالص تحياتي

[عبد الرحمن شفيق]

استاذي القدير العزيز / حمادة عمر

كلما بحثت في مواضيعك ... لاتعلم

اجد الروعة والاتقان

وتقديم المعلومة بكل محبة واخلاص من يد اكبر فنان

فهنيئا لنا نحن تلاميذك

تقبل كل تحياتي

[حمادة عمر]

استاذي القدير العزيز / حمادة عمر

كلما بحثت في مواضيعك ... لاتعلم

اجد الروعة والاتقان

وتقديم المعلومة بكل محبة واخلاص من يد اكبر فنان

فهنيئا لنا نحن تلاميذك

تقبل كل تحياتي

 

مرور طيب وكريم من اخ كريم

تقبل خالص تحياتي اخي الكريم /  عبد الرحمن شفيق